JSON output for cardano-cli

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

@@ -37,6 +37,8 @@ module Cardano.Api.Certificate (
     AsType(..)
   ) where
 
+import           Data.Aeson (ToJSON, Value (..), object, toJSON, (.=))
+import qualified Data.Aeson as Aeson
 import           Data.ByteString (ByteString)
 import qualified Data.Foldable as Foldable
 import qualified Data.Map.Strict as Map
@@ -68,7 +70,9 @@ import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.Keys.Byron
 import           Cardano.Api.Keys.Praos
 import           Cardano.Api.Keys.Shelley
+import           Cardano.Api.Orphans ()
 import           Cardano.Api.SerialiseCBOR
+import           Cardano.Api.SerialiseRaw (serialiseToRawBytesHexText)
 import           Cardano.Api.SerialiseTextEnvelope
 import           Cardano.Api.StakePoolMetadata
 import           Cardano.Api.Value
@@ -108,6 +112,52 @@ instance ToCBOR Certificate where
 instance FromCBOR Certificate where
     fromCBOR = fromShelleyCertificate <$> Shelley.fromEraCBOR @Shelley.Shelley
 
+instance ToJSON Certificate where
+    toJSON a = case a of
+      StakeAddressRegistrationCertificate credential ->
+        object
+          [ "type" .= String "StakeAddressRegistration"
+          , "credential" .= credential
+          ]
+      StakeAddressDeregistrationCertificate credential ->
+        object
+          [ "type" .= String "StakeAddressDeregistration"
+          , "credential" .= credential
+          ]
+      StakeAddressPoolDelegationCertificate credential pool ->
+        object
+          [ "type" .= String "StakeAddressDelegation"
+          , "credential" .= credential
+          , "pool" .= pool
+          ]
+      StakePoolRegistrationCertificate parameters ->
+        object
+          [ "type" .= String "StakePoolRegistration"
+          , "parameters" .= parameters
+          ]
+      StakePoolRetirementCertificate pool epoch ->
+        object
+          [ "type" .= String "StakePoolRetirement"
+          , "pool" .= pool
+          , "epoch" .= epoch
+          ]
+      GenesisKeyDelegationCertificate
+          genesisKeyHash
+          genesisDelegateKeyHash
+          vrfKeyHash ->
+        object
+          [ "type" .= String "GenesisKeyDelegation"
+          , "genesisKeyHash" .= serialiseToRawBytesHexText genesisKeyHash
+          , "genesisDelegateKeyHash" .= serialiseToRawBytesHexText genesisDelegateKeyHash
+          , "vrfKeyHash" .= serialiseToRawBytesHexText vrfKeyHash
+          ]
+      MIRCertificate pot target ->
+        object
+          [ "type" .= String "MIR"
+          , "pot" .= pot
+          , "target" .= target
+          ]
+
 instance HasTextEnvelope Certificate where
     textEnvelopeType _ = "CertificateShelley"
     textEnvelopeDefaultDescr cert = case cert of
@@ -137,6 +187,24 @@ data MIRTarget =
    | SendToTreasuryMIR Lovelace
   deriving stock (Eq, Show)
 
+instance ToJSON MIRTarget where
+  toJSON a = case a of
+    StakeAddressesMIR addresses ->
+      object
+        [ "type" .= String "StakeAddresses"
+        , "addresses" .= addresses
+        ]
+    SendToReservesMIR lovelace ->
+      object
+        [ "type" .= String "SendToReserves"
+        , "lovelace" .= lovelace
+        ]
+    SendToTreasuryMIR lovelace ->
+      object
+        [ "type" .= String "SendToTreasury"
+        , "lovelace" .= lovelace
+        ]
+
 -- ----------------------------------------------------------------------------
 -- Stake pool parameters
 --
@@ -157,13 +225,27 @@ data StakePoolParameters =
      }
   deriving (Eq, Show)
 
+instance ToJSON StakePoolParameters where
+  toJSON ref =
+    object
+      [ "id" .= stakePoolId ref
+      , "vrf" .= serialiseToRawBytesHexText (stakePoolVRF ref)
+      , "cost" .= stakePoolCost ref
+      , "margin" .= stakePoolMargin ref
+      , "rewardAccount" .= stakePoolRewardAccount ref
+      , "pledge" .= stakePoolPledge ref
+      , "owners" .= map serialiseToRawBytesHexText (stakePoolOwners ref)
+      , "relays" .= stakePoolRelays ref
+      , "metadata" .= stakePoolMetadata ref
+      ]
+
 data StakePoolRelay =
 
        -- | One or both of IPv4 & IPv6
        StakePoolRelayIp
           (Maybe IPv4) (Maybe IPv6) (Maybe PortNumber)
 
-       -- | An DNS name pointing to a @A@ or @AAAA@ record.
+       -- | A DNS name pointing to a @A@ or @AAAA@ record.
      | StakePoolRelayDnsARecord
           ByteString (Maybe PortNumber)
 
@@ -173,13 +255,43 @@ data StakePoolRelay =
 
   deriving (Eq, Show)
 
+instance ToJSON StakePoolRelay where
+  toJSON a = case a of
+    StakePoolRelayIp ipv4 ipv6 port ->
+      object
+        [ "type" .= String "IP"
+        , "ipv4" .= ipv4
+        , "ipv6" .= ipv6
+        , "port" .= (portToJson <$> port)
+        ]
+    StakePoolRelayDnsARecord name port ->
+      object
+        [ "type" .= String "DnsA"
+        , "name" .= Text.decodeUtf8 name
+        , "port" .= (portToJson <$> port)
+        ]
+    StakePoolRelayDnsSrvRecord name ->
+      object
+        [ "type" .= String "DnsSrv"
+        , "name" .= Text.decodeUtf8 name
+        ]
+    where
+      portToJson = Aeson.Number . fromIntegral
+
 data StakePoolMetadataReference =
      StakePoolMetadataReference {
        stakePoolMetadataURL  :: Text,
        stakePoolMetadataHash :: Hash StakePoolMetadata
      }
   deriving (Eq, Show)
 
+instance ToJSON StakePoolMetadataReference where
+  toJSON ref =
+    object
+      [ "url" .= stakePoolMetadataURL ref
+      , "hash" .= serialiseToRawBytesHexText (stakePoolMetadataHash ref)
+      ]
+
 
 -- ----------------------------------------------------------------------------
 -- Constructor functions

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

@@ -1,12 +1,29 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
+
 module Cardano.Api.Orphans () where
 
 import           Data.Aeson (ToJSON (..), object, pairs, (.=))
 import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Base16 as Base16
+import           Data.Text (Text)
+import qualified Data.Text.Encoding as Text
 
 import qualified Cardano.Ledger.Crypto as Crypto
+
+import           Cardano.Ledger.Shelley.API (MIRPot (..))
+import qualified Cardano.Ledger.Shelley.API as Ledger (KeyRole (..), WitVKey)
+
+import           Cardano.Api.SerialiseCBOR (ToCBOR (..))
+import           Cardano.Binary (encodeListLen, serialize')
+import           Codec.CBOR.Encoding (encodeWord)
 import qualified Ouroboros.Consensus.Shelley.Ledger.Query as Consensus
 
 -- Orphan instances involved in the JSON output of the API queries.
@@ -47,3 +64,14 @@ stakeSnapshotToPair Consensus.StakeSnapshot
     , "stakeSet" .= ssSetPool
     , "stakeGo" .= ssGoPool
     ]
+
+instance ToJSON MIRPot where
+  toJSON pot = toJSON @Text $
+    case pot of
+      ReservesMIR -> "reserves"
+      TreasuryMIR -> "treasury"
+
+instance Crypto.Crypto crypto => ToJSON (Ledger.WitVKey 'Ledger.Witness crypto) where
+  toJSON = toJSON . Text.decodeLatin1 . Base16.encode . serialize' . prefixWithTag
+   where
+    prefixWithTag wit = encodeListLen 2 <> encodeWord 0 <> toCBOR wit

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

@@ -3,7 +3,6 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -538,7 +537,7 @@ data ProtocolParametersUpdate =
        -- /Introduced in Babbage.  Supercedes 'protocolUpdateUTxOCostPerWord'/
        protocolUpdateUTxOCostPerByte :: Maybe Lovelace
     }
-  deriving (Eq, Show)
+  deriving (Eq, Generic, Show)
 
 instance Semigroup ProtocolParametersUpdate where
     ppu1 <> ppu2 =
@@ -673,6 +672,37 @@ instance FromCBOR ProtocolParametersUpdate where
         <*> fromCBOR
         <*> fromCBOR
 
+instance ToJSON ProtocolParametersUpdate where
+  toJSON ref =
+    object $
+      ( ("protocolVersion" ..=? protocolUpdateProtocolVersion ref)
+      . ("decentralization" ..=? protocolUpdateDecentralization ref)
+      . ("extraPraosEntropy" ..=? protocolUpdateExtraPraosEntropy ref)
+      . ("maxBlockHeaderSize" ..=? protocolUpdateMaxBlockHeaderSize ref)
+      . ("maxBlockBodySize" ..=? protocolUpdateMaxBlockBodySize ref)
+      . ("maxTxSize" ..=? protocolUpdateMaxTxSize ref)
+      . ("txFeeFixed" ..=? protocolUpdateTxFeeFixed ref)
+      . ("txFeePerByte" ..=? protocolUpdateTxFeePerByte ref)
+      . ("minUTxOValue" ..=? protocolUpdateMinUTxOValue ref)
+      . ("stakeAddressDeposit" ..=? protocolUpdateStakeAddressDeposit ref)
+      . ("stakePoolDeposit" ..=? protocolUpdateStakePoolDeposit ref)
+      . ("minPoolCost" ..=? protocolUpdateMinPoolCost ref)
+      . ("poolRetireMaxEpoch" ..=? protocolUpdatePoolRetireMaxEpoch ref)
+      . ("stakePoolTargetNum" ..=? protocolUpdateStakePoolTargetNum ref)
+      . ("poolPledgeInfluence" ..=? protocolUpdatePoolPledgeInfluence ref)
+      . ("monetaryExpansion" ..=? protocolUpdateMonetaryExpansion ref)
+      . ("treasuryCut" ..=? protocolUpdateTreasuryCut ref)
+      . ("utxoCostPerWord" ..=? protocolUpdateUTxOCostPerWord ref)
+      . ("costModels" ..= protocolUpdateCostModels ref)
+      . ("prices" ..=? protocolUpdatePrices ref)
+      . ("maxTxExUnits" ..=? protocolUpdateMaxTxExUnits ref)
+      . ("maxBlockExUnits" ..=? protocolUpdateMaxBlockExUnits ref)
+      . ("maxValueSize" ..=? protocolUpdateMaxValueSize ref)
+      . ("collateralPercent" ..=? protocolUpdateCollateralPercent ref)
+      . ("maxCollateralInputs" ..=? protocolUpdateMaxCollateralInputs ref)
+      . ("utxoCostPerByte" ..=? protocolUpdateUTxOCostPerByte ref)
+      ) []
+
 
 -- ----------------------------------------------------------------------------
 -- Praos nonce
@@ -778,7 +808,7 @@ fromAlonzoPrices Alonzo.Prices{Alonzo.prSteps, Alonzo.prMem} =
 
 newtype CostModel = CostModel [Integer]
   deriving (Eq, Show)
-  deriving newtype (ToCBOR, FromCBOR)
+  deriving newtype (ToCBOR, FromCBOR, ToJSON)
 
 newtype CostModels = CostModels { unCostModels :: Map AnyPlutusScriptVersion CostModel }
   deriving (Eq, Show)
@@ -845,7 +875,7 @@ data UpdateProposal =
      UpdateProposal
        !(Map (Hash GenesisKey) ProtocolParametersUpdate)
        !EpochNo
-    deriving stock (Eq, Show)
+    deriving stock (Eq, Generic, Show)
     deriving anyclass SerialiseAsCBOR
 
 instance HasTypeProxy UpdateProposal where
@@ -868,6 +898,13 @@ instance FromCBOR UpdateProposal where
         <$> fromCBOR
         <*> fromCBOR
 
+instance ToJSON UpdateProposal where
+  toJSON (UpdateProposal updates epoch) =
+    object
+      [ "updates" .= Map.mapKeys serialiseToRawBytesHexText updates
+      , "epoch" .= epoch
+      ]
+
 makeShelleyUpdateProposal :: ProtocolParametersUpdate
                           -> [Hash GenesisKey]
                           -> EpochNo
@@ -1247,7 +1284,7 @@ unbundleLedgerShelleyBasedProtocolParams
   :: ShelleyBasedEra era
   -> BundledProtocolParameters era
   -> Ledger.PParams (ShelleyLedgerEra era)
-unbundleLedgerShelleyBasedProtocolParams = \case
+unbundleLedgerShelleyBasedProtocolParams era = case era of
   ShelleyBasedEraShelley -> \(BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp
   ShelleyBasedEraAllegra -> \(BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp
   ShelleyBasedEraMary -> \(BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp

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

@@ -1,9 +1,9 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -106,6 +106,7 @@ module Cardano.Api.Script (
     Hash(..),
   ) where
 
+import qualified Data.ByteString.Base16 as Base16
 import qualified Data.ByteString.Lazy as LBS
 import           Data.ByteString.Short (ShortByteString)
 import qualified Data.ByteString.Short as SBS
@@ -247,6 +248,9 @@ instance TestEquality PlutusScriptVersion where
     testEquality PlutusScriptV2 PlutusScriptV2 = Just Refl
     testEquality _ _ = Nothing
 
+instance ToJSON (PlutusScriptVersion lang) where
+  toJSON = toJSON . fromEnum . AnyScriptLanguage . PlutusScriptLanguage
+
 
 data AnyScriptLanguage where
      AnyScriptLanguage :: ScriptLanguage lang -> AnyScriptLanguage
@@ -428,6 +432,19 @@ instance IsScriptLanguage lang => HasTextEnvelope (Script lang) where
         PlutusScriptLanguage PlutusScriptV1 -> "PlutusScriptV1"
         PlutusScriptLanguage PlutusScriptV2 -> "PlutusScriptV2"
 
+instance ToJSON (Script lang) where
+  toJSON a = case a of
+    SimpleScript script ->
+      object
+        [ "type" .= String "simple"
+        , "script" .= script
+        ]
+    PlutusScript version script ->
+      object
+        [ "type" .= String "plutus"
+        , "version" .= version
+        , "script" .= script
+        ]
 
 -- ----------------------------------------------------------------------------
 -- Scripts in any language
@@ -513,6 +530,13 @@ instance Eq (ScriptInEra era) where
         Nothing   -> False
         Just Refl -> script == script'
 
+instance ToJSON (ScriptInEra era) where
+  toJSON (ScriptInEra language script) =
+    object
+      [ "language" .= language
+      , "script" .= script
+      ]
+
 
 data ScriptLanguageInEra lang era where
 
@@ -983,6 +1007,12 @@ instance IsPlutusScriptLanguage lang => HasTextEnvelope (PlutusScript lang) wher
         PlutusScriptV1 -> "PlutusScriptV1"
         PlutusScriptV2 -> "PlutusScriptV2"
 
+instance ToJSON (PlutusScript lang) where
+  toJSON (PlutusScriptSerialised bytes) =
+    object
+      [ "base16" .= Text.decodeUtf8 (Base16.encode $ SBS.fromShort bytes)
+      ]
+
 
 -- | An example Plutus script that always succeeds, irrespective of inputs.
 --
@@ -1324,7 +1354,7 @@ instance IsCardanoEra era => FromJSON (ReferenceScript era) where
         ReferenceScript refSupInEra <$> o .: "referenceScript"
 
 instance EraCast ReferenceScript where
-  eraCast toEra = \case
+  eraCast toEra a = case a of
     ReferenceScriptNone -> pure ReferenceScriptNone
     v@(ReferenceScript (_ :: ReferenceTxInsScriptsInlineDatumsSupportedInEra fromEra) scriptInAnyLang) ->
       case refInsScriptsAndInlineDatsSupportedInEra toEra of