Add ToJSON/FromJSON instances for EraScript

* Add ToJSON/FromJSON as superclass constraints to EraScript
* Add ToJSON/FromJSON instances for MultiSig, Timelock and DijkstraNativeScript
* Add structured JSON serialisation for native scripts across all eras (Shelley, Allegra, Dijkstra)
* Add ToJSON/FromJSON instances for AlonzoScript with structured JSON format
* Rename kindObject (returning Value) to kindObjectValue; add new kindObject returning Aeson.Object
* Fix shelleyBasedEraNativeScriptToJSON and sizedNativeScriptGens to accept a child continuation to correctly handle nested scripts across eras
* Add round-trip JSON property tests for NativeScript and Script to the shared era spec

Author: koslambrou

eras/allegra/impl/CHANGELOG.md

@@ -7,6 +7,8 @@
 * Add `ApplyTick` instance for `AllegraEra`
 * Add `EraForecast` and `ShelleyEraForecast` instances for `AllegraEra`.
 * Remove `NoThunks` instance for `AllegraUtxoPredFailure`
+* Add `ToJSON` and `FromJSON` instances for `Timelock era`
+* Export `allegraBasedEraNativeScriptToJSON` and `allegraBasedEraNativeScriptJSONParser` from `Cardano.Ledger.Allegra.Scripts`
 
 ### `cddl`
 

eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
@@ -58,10 +57,14 @@ module Cardano.Ledger.Allegra.Scripts (
   ltePosInfty,
   invalidBeforeL,
   invalidHereAfterL,
+
+  -- ** JSON utilities
+  allegraBasedEraNativeScriptToJSON,
+  allegraBasedEraNativeScriptJSONParser,
 ) where
 
 import Cardano.Ledger.Allegra.Era (AllegraEra)
-import Cardano.Ledger.BaseTypes (StrictMaybe (..), maybeToStrictMaybe)
+import Cardano.Ledger.BaseTypes (StrictMaybe (..), kindObject, maybeToStrictMaybe)
 import Cardano.Ledger.Binary (
   Annotator,
   DecCBOR (decCBOR),
@@ -98,20 +101,26 @@ import Cardano.Ledger.MemoBytes.Internal (mkMemoBytesShort)
 import Cardano.Ledger.Shelley.Scripts (
   ShelleyEraScript (..),
   nativeMultiSigTag,
+  shelleyBasedEraNativeScriptJSONParser,
+  shelleyBasedEraNativeScriptToJSON,
   pattern RequireAllOf,
   pattern RequireAnyOf,
   pattern RequireMOf,
   pattern RequireSignature,
  )
 import Cardano.Slotting.Slot (SlotNo (..))
+import Control.Applicative ((<|>))
 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 (foldl')
-import Data.MemPack
+import Data.MemPack (MemPack (packM, packedByteCount, unpackM))
+import Data.Proxy (Proxy (Proxy))
 import Data.Sequence.Strict as Seq (StrictSeq (Empty, (:<|)))
 import qualified Data.Sequence.Strict as SSeq
 import qualified Data.Set as Set (Set, member)
+import Data.Typeable (typeRep)
 import GHC.Generics (Generic)
 import Lens.Micro (Lens', lens)
 import NoThunks.Class (NoThunks (..))
@@ -265,6 +274,48 @@ deriving instance Show (Timelock era)
 instance EqRaw (Timelock era) where
   eqRaw = eqTimelockRaw
 
+instance (AllegraEraScript era, NativeScript era ~ Timelock era) => ToJSON (Timelock era) where
+  toJSON =
+    let go = allegraBasedEraNativeScriptToJSON go
+     in Aeson.Object . go
+
+allegraBasedEraNativeScriptToJSON ::
+  AllegraEraScript era =>
+  (NativeScript era -> Aeson.Object) ->
+  NativeScript era ->
+  Aeson.Object
+allegraBasedEraNativeScriptToJSON childNativeScriptToObject script =
+  shelleyBasedEraNativeScriptToJSON childNativeScriptToObject script
+    <> case script of
+      RequireTimeStart s ->
+        kindObject "TimeStart" ["slot" .= s]
+      RequireTimeExpire s ->
+        kindObject "TimeExpire" ["slot" .= s]
+      _ -> mempty
+
+instance (AllegraEraScript era, NativeScript era ~ Timelock era) => FromJSON (Timelock era) where
+  parseJSON = allegraBasedEraNativeScriptJSONParser
+
+allegraBasedEraNativeScriptJSONParser ::
+  forall era.
+  AllegraEraScript era =>
+  Aeson.Value ->
+  Parser (NativeScript era)
+allegraBasedEraNativeScriptJSONParser value =
+  shelleyBasedEraNativeScriptJSONParser value
+    <|> Aeson.withObject
+      typeName
+      ( \o -> do
+          t <- o .: "kind" :: Parser String
+          case t of
+            "TimeStart" -> RequireTimeStart @era <$> o .: "slot"
+            "TimeExpire" -> RequireTimeExpire @era <$> o .: "slot"
+            _ -> fail $ "Unknown " <> typeName <> " kind: " <> t
+      )
+      value
+  where
+    typeName = show $ typeRep (Proxy @(NativeScript era))
+
 upgradeMultiSig :: NativeScript ShelleyEra -> NativeScript AllegraEra
 upgradeMultiSig = \case
   RequireSignature keyHash -> RequireSignature keyHash

eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Arbitrary.hs

@@ -59,7 +59,7 @@ sizedTimelock ::
 sizedTimelock 0 = RequireSignature <$> arbitrary
 sizedTimelock n =
   oneof $
-    sizedNativeScriptGens n
+    sizedNativeScriptGens n sizedTimelock
       <> [ RequireTimeStart <$> arbitrary
          , RequireTimeExpire <$> arbitrary
          ]

eras/alonzo/impl/CHANGELOG.md

@@ -40,6 +40,7 @@
 * Remove `NoThunks (ContextError era)` constraint from `EraPlutusContext` class
 * Remove `NoThunks` deriving instance for `CollectError`
 * Make `AlonzoContextError` constructors lazy
+* Add `ToJSON` and `FromJSON` instances for `AlonzoScript era`
 
 ### `cddl`
 

eras/alonzo/impl/cardano-ledger-alonzo.cabal

@@ -90,6 +90,7 @@ library
     FailT,
     aeson >=2.2,
     base >=4.18 && <5,
+    base16-bytestring,
     base64-bytestring,
     bytestring,
     cardano-base >=0.1.1.0,

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs

@@ -52,7 +52,7 @@ import Cardano.Ledger.Alonzo.Scripts (
   PlutusPurpose,
   PlutusScript (..),
  )
-import Cardano.Ledger.BaseTypes (ProtVer (..), kindObject)
+import Cardano.Ledger.BaseTypes (ProtVer (..), kindObjectValue)
 import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
 import Cardano.Ledger.Binary.Coders
 import Cardano.Ledger.Core
@@ -384,19 +384,22 @@ instance
   where
   toJSON = \case
     NoRedeemer sPurpose ->
-      kindObject "CollectError" $
+      kindObjectValue
+        "CollectError"
         [ "error" .= String "NoRedeemer"
         , "plutusPurpose" .= toJSON sPurpose
         ]
     NoWitness sHash ->
-      kindObject "CollectError" $
+      kindObjectValue
+        "CollectError"
         [ "error" .= String "NoWitness"
         , "scriptHash" .= toJSON sHash
         ]
     NoCostModel lang ->
-      kindObject "CollectError" $
+      kindObjectValue
+        "CollectError"
         [ "error" .= String "NoCostModel"
         , "language" .= toJSON lang
         ]
     BadTranslation err ->
-      kindObject "BadTranslation" ["error" .= toJSON err]
+      kindObjectValue "BadTranslation" ["error" .= toJSON err]

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs

@@ -49,7 +49,7 @@ import Cardano.Ledger.BaseTypes (
   ShelleyBase,
   StrictMaybe,
   epochInfo,
-  kindObject,
+  kindObjectValue,
   systemStart,
  )
 import Cardano.Ledger.Binary (
@@ -314,7 +314,7 @@ instance DecCBOR FailureDescription where
 
 instance ToJSON FailureDescription where
   toJSON (PlutusFailure t _bs) =
-    kindObject
+    kindObjectValue
       "FailureDescription"
       [ "error" .= Aeson.String "PlutusFailure"
       , "description" .= t
@@ -347,11 +347,11 @@ instance DecCBOR TagMismatchDescription where
 instance ToJSON TagMismatchDescription where
   toJSON = \case
     PassedUnexpectedly ->
-      kindObject
+      kindObjectValue
         "TagMismatchDescription"
         ["error" .= Aeson.String "PassedUnexpectedly"]
     FailedUnexpectedly forReasons ->
-      kindObject
+      kindObjectValue
         "TagMismatchDescription"
         [ "error" .= Aeson.String "FailedUnexpectedly"
         , "reconstruction" .= forReasons

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs

@@ -65,7 +65,7 @@ module Cardano.Ledger.Alonzo.Scripts (
 import Cardano.Ledger.Allegra.Scripts
 import Cardano.Ledger.Alonzo.Era (AlonzoEra)
 import Cardano.Ledger.Alonzo.TxCert ()
-import Cardano.Ledger.BaseTypes (ProtVer (..), kindObject)
+import Cardano.Ledger.BaseTypes (ProtVer (..), kindObjectValue)
 import Cardano.Ledger.Binary (
   Annotator,
   CBORGroup (..),
@@ -88,7 +88,6 @@ import Cardano.Ledger.Binary.Coders (
   (!>),
   (<*!),
  )
-import Cardano.Ledger.Binary.Plain (serializeAsHexText)
 import Cardano.Ledger.Core
 import Cardano.Ledger.Mary.Value (PolicyID)
 import Cardano.Ledger.MemoBytes (EqRaw (..))
@@ -102,6 +101,7 @@ import Cardano.Ledger.Plutus.Language (
   SLanguage (..),
   asSLanguage,
   isValidPlutus,
+  languageFromText,
   plutusLanguage,
   plutusSLanguage,
   withSLanguage,
@@ -110,12 +110,28 @@ import Cardano.Ledger.Shelley.Scripts (ShelleyEraScript (..), nativeMultiSigTag)
 import Cardano.Ledger.TxIn (TxIn)
 import Control.DeepSeq (NFData (..), deepseq, rwhnf)
 import Control.Monad (guard, (>=>))
-import Data.Aeson (ToJSON (..), Value (String), object, (.=))
+import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), object, withObject, (.:), (.=))
+import qualified Data.Aeson as Aeson
+import Data.Aeson.Types (Parser)
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as BS16
+import qualified Data.ByteString.Base64 as BS64
+import qualified Data.ByteString.Short as SBS
 import Data.Kind (Type)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromJust, isJust)
-import Data.MemPack
+import Data.MemPack (
+  MemPack,
+  packM,
+  packTagM,
+  packedByteCount,
+  packedTagByteCount,
+  unknownTagM,
+  unpackM,
+  unpackTagM,
+ )
+import Data.Text (Text)
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Typeable
 import Data.Word (Word32)
 import GHC.Generics (Generic)
@@ -296,6 +312,11 @@ instance (ToJSON ix, ToJSON it) => ToJSON (AsIxItem ix it) where
       , "item" .= toJSON it
       ]
 
+instance FromJSON ix => FromJSON (AsIx ix it) where
+  parseJSON =
+    withObject "AsIx" $ \o ->
+      AsIx <$> o .: "index"
+
 toAsPurpose :: f ix it -> AsPurpose ix it
 toAsPurpose = const AsPurpose
 
@@ -406,7 +427,25 @@ instance
     AlonzoCertifying n -> kindObjectWithValue "AlonzoCertifying" n
     AlonzoRewarding n -> kindObjectWithValue "AlonzoRewarding" n
     where
-      kindObjectWithValue name n = kindObject name ["value" .= n]
+      kindObjectWithValue name n = kindObjectValue name ["value" .= n]
+
+instance
+  ( FromJSON (AsIx Word32 TxIn)
+  , FromJSON (AsIx Word32 PolicyID)
+  , FromJSON (AsIx Word32 (TxCert era))
+  , FromJSON (AsIx Word32 AccountAddress)
+  ) =>
+  FromJSON (AlonzoPlutusPurpose AsIx era)
+  where
+  parseJSON =
+    withObject "AlonzoPlutusPurpose" $ \o -> do
+      kind <- o .: "kind" :: Parser Text
+      case kind of
+        "AlonzoSpending" -> AlonzoSpending <$> o .: "value"
+        "AlonzoMinting" -> AlonzoMinting <$> o .: "value"
+        "AlonzoCertifying" -> AlonzoCertifying <$> o .: "value"
+        "AlonzoRewarding" -> AlonzoRewarding <$> o .: "value"
+        _ -> fail $ "Unknown AlonzoPlutusPurpose kind: " <> show kind
 
 pattern SpendingPurpose ::
   AlonzoEraScript era => f Word32 TxIn -> PlutusPurpose f era
@@ -579,8 +618,41 @@ instance
   where
   eqRaw = eqAlonzoScriptRaw
 
-instance AlonzoEraScript era => ToJSON (AlonzoScript era) where
-  toJSON = String . serializeAsHexText
+instance (AlonzoEraScript era, Script era ~ AlonzoScript era) => ToJSON (AlonzoScript era) where
+  toJSON script =
+    object $
+      [ "scriptHash" .= hashScript script
+      , "scriptBase16Tag" .= toBase16Text (scriptPrefixTag script)
+      , "scriptBase64Bytes" .= toBase64Text (originalBytes script)
+      , "scriptType"
+          .= case script of
+            NativeScript _ -> Aeson.String "NativeScript"
+            PlutusScript plutusScript -> toJSON (withPlutusScript plutusScript plutusLanguage)
+      ]
+        ++ case script of
+          NativeScript nativeScript -> ["nativeScriptContents" .= toJSON nativeScript]
+          PlutusScript _ -> []
+    where
+      toBase64Text = decodeLatin1 . BS64.encode
+      toBase16Text = ("0x" <>) . decodeLatin1 . BS16.encode
+
+instance AlonzoEraScript era => FromJSON (AlonzoScript era) where
+  parseJSON = withObject typeName $ \o -> do
+    scriptType <- o .: "scriptType" :: Parser Text
+    case scriptType of
+      "NativeScript" -> NativeScript <$> o .: "nativeScriptContents"
+      _ -> do
+        lang <- languageFromText scriptType
+        b64 <- o .: "scriptBase64Bytes" :: Parser Text
+        bytes <-
+          either
+            (fail . ("AlonzoScript: invalid base64: " <>))
+            pure
+            (BS64.decode (encodeUtf8 b64))
+        let pb = PlutusBinary (SBS.toShort bytes)
+        PlutusScript <$> mkBinaryPlutusScript lang pb
+    where
+      typeName = show $ typeRep (Proxy @(AlonzoScript era))
 
 -- | It might seem that this instance unnecessarily utilizes a zero Tag, but it is needed for
 -- forward compatibility with plutus scripts from future eras.
@@ -620,12 +692,13 @@ instance AlonzoEraScript era => ToCBOR (AlonzoScript era) where
 encodeScript :: AlonzoEraScript era => AlonzoScript era -> Encode Open (AlonzoScript era)
 encodeScript = \case
   NativeScript i -> Sum NativeScript 0 !> To i
-  PlutusScript plutusScript -> withPlutusScript plutusScript $ \plutus@(Plutus pb) ->
-    case plutusSLanguage plutus of
-      SPlutusV1 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV1) 1 !> To pb
-      SPlutusV2 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV2) 2 !> To pb
-      SPlutusV3 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV3) 3 !> To pb
-      SPlutusV4 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV4) 4 !> To pb
+  PlutusScript plutusScript ->
+    withPlutusScript plutusScript $ \plutus@(Plutus pb) ->
+      case plutusSLanguage plutus of
+        SPlutusV1 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV1) 1 !> To pb
+        SPlutusV2 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV2) 2 !> To pb
+        SPlutusV3 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV3) 3 !> To pb
+        SPlutusV4 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV4) 4 !> To pb
 
 instance AlonzoEraScript era => DecCBOR (Annotator (AlonzoScript era)) where
   decCBOR = decode (Summands "AlonzoScript" decodeScript)

eras/babbage/impl/src/Cardano/Ledger/Babbage/TxInfo.hs

@@ -53,7 +53,7 @@ import Cardano.Ledger.BaseTypes (
   ProtVer,
   StrictMaybe (..),
   isSJust,
-  kindObject,
+  kindObjectValue,
  )
 import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
 import Cardano.Ledger.Binary.Coders (
@@ -301,7 +301,7 @@ instance ToJSON (PlutusPurpose AsIx era) => ToJSON (BabbageContextError era) whe
     ByronTxOutInContext txOutSource ->
       String $ "Byron UTxO being created or spent: " <> txOutSourceToText txOutSource
     RedeemerPointerPointsToNothing ptr ->
-      kindObject "RedeemerPointerPointsToNothing" ["ptr" .= toJSON ptr]
+      kindObjectValue "RedeemerPointerPointsToNothing" ["ptr" .= toJSON ptr]
     InlineDatumsNotSupported txOutSource ->
       String $ "Inline datums not supported, output source: " <> txOutSourceToText txOutSource
     ReferenceScriptsNotSupported txOutSource ->

eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs

@@ -35,7 +35,7 @@ import Cardano.Ledger.Alonzo.Scripts (
  )
 import Cardano.Ledger.Babbage.Core
 import Cardano.Ledger.Babbage.Scripts (PlutusScript (..))
-import Cardano.Ledger.BaseTypes (kindObject)
+import Cardano.Ledger.BaseTypes (kindObjectValue)
 import Cardano.Ledger.Binary (
   CBORGroup (..),
   DecCBOR (decCBOR),
@@ -310,7 +310,7 @@ instance
     ConwayVoting n -> kindObjectWithValue "ConwayVoting" n
     ConwayProposing n -> kindObjectWithValue "ConwayProposing" n
     where
-      kindObjectWithValue name n = kindObject name ["value" .= n]
+      kindObjectWithValue name n = kindObjectValue name ["value" .= n]
 
 pattern VotingPurpose ::
   ConwayEraScript era => f Word32 Voter -> PlutusPurpose f era