Skip to content

Commit f8082a6

Browse files
cblpcblp
committed
WIP
1 parent 6971bbc commit f8082a6

File tree

15 files changed

+636
-39
lines changed

15 files changed

+636
-39
lines changed

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ module Cardano.Api (
2323
AnyCardanoEra(..),
2424
anyCardanoEra,
2525
InAnyCardanoEra(..),
26+
withCardanoEra,
2627

2728
-- ** Shelley-based eras
2829
ShelleyBasedEra(..),

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

Lines changed: 105 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
11
{-# LANGUAGE DeriveAnyClass #-}
22
{-# LANGUAGE DerivingStrategies #-}
3+
{-# LANGUAGE LambdaCase #-}
34
{-# LANGUAGE NamedFieldPuns #-}
5+
{-# LANGUAGE RecordWildCards #-}
46
{-# LANGUAGE TypeFamilies #-}
57

68
-- | Certificates embedded in transactions
@@ -38,6 +40,8 @@ module Cardano.Api.Certificate (
3840

3941
import Prelude
4042

43+
import Data.Aeson (ToJSON, object, toJSON, (.=))
44+
import qualified Data.Aeson as Aeson
4145
import Data.ByteString (ByteString)
4246
import qualified Data.Foldable as Foldable
4347
import qualified Data.Map.Strict as Map
@@ -62,12 +66,13 @@ import Cardano.Ledger.Shelley.TxBody (MIRPot (..))
6266
import qualified Cardano.Ledger.Shelley.TxBody as Shelley
6367

6468
import Cardano.Api.Address
65-
import Cardano.Api.HasTypeProxy
6669
import Cardano.Api.Hash
70+
import Cardano.Api.HasTypeProxy
6771
import Cardano.Api.KeysByron
6872
import Cardano.Api.KeysPraos
6973
import Cardano.Api.KeysShelley
7074
import Cardano.Api.SerialiseCBOR
75+
import Cardano.Api.SerialiseRaw (serialiseToRawBytesHexText)
7176
import Cardano.Api.SerialiseTextEnvelope
7277
import Cardano.Api.StakePoolMetadata
7378
import Cardano.Api.Value
@@ -107,6 +112,50 @@ instance ToCBOR Certificate where
107112
instance FromCBOR Certificate where
108113
fromCBOR = fromShelleyCertificate <$> fromCBOR
109114

115+
instance ToJSON Certificate where
116+
toJSON =
117+
object
118+
. \case
119+
StakeAddressRegistrationCertificate credential ->
120+
[ "type" .= ("StakeAddressRegistration" :: Text)
121+
, "credential" .= credential
122+
]
123+
StakeAddressDeregistrationCertificate credential ->
124+
[ "type" .= ("StakeAddressDeregistration" :: Text)
125+
, "credential" .= credential
126+
]
127+
StakeAddressDelegationCertificate credential pool ->
128+
[ "type" .= ("StakeAddressDelegation" :: Text)
129+
, "credential" .= credential
130+
, "pool" .= pool
131+
]
132+
StakePoolRegistrationCertificate parameters ->
133+
[ "type" .= ("StakePoolRegistration" :: Text)
134+
, "parameters" .= parameters
135+
]
136+
StakePoolRetirementCertificate pool epoch ->
137+
[ "type" .= ("StakePoolRetirement" :: Text)
138+
, "pool" .= pool
139+
, "epoch" .= epoch
140+
]
141+
GenesisKeyDelegationCertificate genesisKeyHash
142+
genesisDelegateKeyHash
143+
vrfKeyHash ->
144+
[ "type" .= ("GenesisKeyDelegation" :: Text)
145+
, "genesisKeyHash" .= serialiseToRawBytesHexText genesisKeyHash
146+
, "genesisDelegateKeyHash"
147+
.= serialiseToRawBytesHexText genesisDelegateKeyHash
148+
, "vrfKeyHash" .= serialiseToRawBytesHexText vrfKeyHash
149+
]
150+
MIRCertificate pot target ->
151+
[ "type" .= ("MIR" :: Text)
152+
, "pot"
153+
.= case pot of
154+
ReservesMIR -> "reserves"
155+
TreasuryMIR -> "reserves" :: Text
156+
, "target" .= target
157+
]
158+
110159
instance HasTextEnvelope Certificate where
111160
textEnvelopeType _ = "CertificateShelley"
112161
textEnvelopeDefaultDescr cert = case cert of
@@ -136,6 +185,17 @@ data MIRTarget =
136185
| SendToTreasuryMIR Lovelace
137186
deriving stock (Eq, Show)
138187

188+
instance ToJSON MIRTarget where
189+
toJSON =
190+
object
191+
. \case
192+
StakeAddressesMIR addresses ->
193+
["type" .= ("StakeAddresses" :: Text), "addresses" .= addresses]
194+
SendToReservesMIR lovelace ->
195+
["type" .= ("SendToReserves" :: Text), "lovelace" .= lovelace]
196+
SendToTreasuryMIR lovelace ->
197+
["type" .= ("SendToTreasury" :: Text), "lovelace" .= lovelace]
198+
139199
-- ----------------------------------------------------------------------------
140200
-- Stake pool parameters
141201
--
@@ -156,13 +216,27 @@ data StakePoolParameters =
156216
}
157217
deriving (Eq, Show)
158218

219+
instance ToJSON StakePoolParameters where
220+
toJSON StakePoolParameters{..} =
221+
object
222+
[ "id" .= stakePoolId
223+
, "vrf" .= serialiseToRawBytesHexText stakePoolVRF
224+
, "cost" .= stakePoolCost
225+
, "margin" .= stakePoolMargin
226+
, "rewardAccount" .= stakePoolRewardAccount
227+
, "pledge" .= stakePoolPledge
228+
, "owners" .= map serialiseToRawBytesHexText stakePoolOwners
229+
, "relays" .= stakePoolRelays
230+
, "metadata" .= stakePoolMetadata
231+
]
232+
159233
data StakePoolRelay =
160234

161235
-- | One or both of IPv4 & IPv6
162236
StakePoolRelayIp
163237
(Maybe IPv4) (Maybe IPv6) (Maybe PortNumber)
164238

165-
-- | An DNS name pointing to a @A@ or @AAAA@ record.
239+
-- | A DNS name pointing to a @A@ or @AAAA@ record.
166240
| StakePoolRelayDnsARecord
167241
ByteString (Maybe PortNumber)
168242

@@ -172,13 +246,42 @@ data StakePoolRelay =
172246

173247
deriving (Eq, Show)
174248

249+
instance ToJSON StakePoolRelay where
250+
toJSON =
251+
object
252+
. \case
253+
StakePoolRelayIp ipv4 ipv6 port ->
254+
[ "type" .= ("IP" :: Text)
255+
, "ipv4" .= ipv4
256+
, "ipv6" .= ipv6
257+
, "port" .= (portToJson <$> port)
258+
]
259+
StakePoolRelayDnsARecord name port ->
260+
[ "type" .= ("DnsA" :: Text)
261+
, "name" .= Text.decodeUtf8 name
262+
, "port" .= (portToJson <$> port)
263+
]
264+
StakePoolRelayDnsSrvRecord name ->
265+
[ "type" .= ("DnsSrv" :: Text)
266+
, "name" .= Text.decodeUtf8 name
267+
]
268+
where
269+
portToJson = Aeson.Number . fromIntegral
270+
175271
data StakePoolMetadataReference =
176272
StakePoolMetadataReference {
177273
stakePoolMetadataURL :: Text,
178274
stakePoolMetadataHash :: Hash StakePoolMetadata
179275
}
180276
deriving (Eq, Show)
181277

278+
instance ToJSON StakePoolMetadataReference where
279+
toJSON StakePoolMetadataReference{..} =
280+
object
281+
[ "url" .= stakePoolMetadataURL
282+
, "hash" .= serialiseToRawBytesHexText stakePoolMetadataHash
283+
]
284+
182285

183286
-- ----------------------------------------------------------------------------
184287
-- Constructor functions

‎cardano-api/src/Cardano/Api/Eras.hs

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ module Cardano.Api.Eras
2121
, AnyCardanoEra(..)
2222
, anyCardanoEra
2323
, InAnyCardanoEra(..)
24+
, withCardanoEra
2425

2526
-- * Deprecated aliases
2627
, Byron
@@ -335,6 +336,17 @@ instance IsShelleyBasedEra BabbageEra where
335336
shelleyBasedEra = ShelleyBasedEraBabbage
336337

337338

339+
-- | Helper function to get an instance from a value
340+
withCardanoEra :: CardanoEra era -> (IsCardanoEra era => a) -> a
341+
withCardanoEra e a =
342+
case e of
343+
ByronEra -> a
344+
ShelleyEra -> a
345+
AllegraEra -> a
346+
MaryEra -> a
347+
AlonzoEra -> a
348+
BabbageEra -> a
349+
338350
-- | Helper function to get an instance from a value
339351
withShelleyBasedCardanoEra :: ShelleyBasedEra era
340352
-> (IsCardanoEra era => a)

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

Lines changed: 29 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -2,9 +2,11 @@
22
{-# LANGUAGE DeriveGeneric #-}
33
{-# LANGUAGE DerivingVia #-}
44
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+
{-# LANGUAGE LambdaCase #-}
56
{-# LANGUAGE NamedFieldPuns #-}
67
{-# LANGUAGE RecordWildCards #-}
78
{-# LANGUAGE ScopedTypeVariables #-}
9+
{-# LANGUAGE StandaloneDeriving #-}
810
{-# LANGUAGE TypeFamilies #-}
911

1012
-- | The various Cardano protocol parameters, including:
@@ -64,10 +66,11 @@ module Cardano.Api.ProtocolParameters (
6466
import Prelude
6567

6668
import Control.Monad
67-
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?),
68-
(.=))
69+
import Data.Aeson (FromJSON (..), ToJSON (..), defaultOptions, fieldLabelModifier,
70+
genericToJSON, object, withObject, (.!=), (.:), (.:?), (.=))
6971
import Data.Bifunctor (bimap)
7072
import Data.ByteString (ByteString)
73+
import Data.Char (toLower)
7174
import Data.Map.Strict (Map)
7275
import qualified Data.Map.Strict as Map
7376
import Data.Maybe (fromMaybe, isJust, isNothing)
@@ -104,8 +107,8 @@ import Cardano.Ledger.Babbage.Translation (coinsPerUTxOWordToCoinsPerU
104107
import Cardano.Api.Address
105108
import Cardano.Api.Eras
106109
import Cardano.Api.Error
107-
import Cardano.Api.HasTypeProxy
108110
import Cardano.Api.Hash
111+
import Cardano.Api.HasTypeProxy
109112
import Cardano.Api.KeysByron
110113
import Cardano.Api.KeysShelley
111114
import Cardano.Api.Script
@@ -512,7 +515,7 @@ data ProtocolParametersUpdate =
512515
-- /Introduced in Alonzo/
513516
protocolUpdateMaxCollateralInputs :: Maybe Natural
514517
}
515-
deriving (Eq, Show)
518+
deriving (Eq, Generic, Show)
516519

517520
instance Semigroup ProtocolParametersUpdate where
518521
ppu1 <> ppu2 =
@@ -642,6 +645,15 @@ instance FromCBOR ProtocolParametersUpdate where
642645
<*> fromCBOR
643646
<*> fromCBOR
644647

648+
instance ToJSON ProtocolParametersUpdate where
649+
toJSON =
650+
genericToJSON defaultOptions{fieldLabelModifier = lowerFirst . drop 14}
651+
where
652+
lowerFirst = \case
653+
"" -> ""
654+
'U':'T':'x':'O':xs -> "utxo" ++ xs
655+
x:xs -> toLower x : xs
656+
645657

646658
-- ----------------------------------------------------------------------------
647659
-- Praos nonce
@@ -811,7 +823,7 @@ data UpdateProposal =
811823
UpdateProposal
812824
!(Map (Hash GenesisKey) ProtocolParametersUpdate)
813825
!EpochNo
814-
deriving stock (Eq, Show)
826+
deriving stock (Eq, Generic, Show)
815827
deriving anyclass SerialiseAsCBOR
816828

817829
instance HasTypeProxy UpdateProposal where
@@ -834,6 +846,18 @@ instance FromCBOR UpdateProposal where
834846
<$> fromCBOR
835847
<*> fromCBOR
836848

849+
newtype UpdateProposalToJson = UpdateProposalToJson UpdateProposal
850+
851+
instance ToJSON UpdateProposalToJson where
852+
toJSON (UpdateProposalToJson (UpdateProposal updates epoch)) =
853+
object
854+
[ "tag" .= ("UpdateProposal" :: Text)
855+
, "update" .= Map.mapKeys serialiseToRawBytesHexText updates
856+
, "epoch" .= epoch
857+
]
858+
859+
deriving via UpdateProposalToJson instance ToJSON UpdateProposal
860+
837861
makeShelleyUpdateProposal :: ProtocolParametersUpdate
838862
-> [Hash GenesisKey]
839863
-> EpochNo

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

Lines changed: 30 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE DerivingVia #-}
33
{-# LANGUAGE FlexibleInstances #-}
44
{-# LANGUAGE GADTs #-}
5+
{-# LANGUAGE LambdaCase #-}
56
{-# LANGUAGE NamedFieldPuns #-}
67
{-# LANGUAGE RankNTypes #-}
78
{-# LANGUAGE ScopedTypeVariables #-}
@@ -105,6 +106,7 @@ module Cardano.Api.Script (
105106

106107
import Prelude
107108

109+
import qualified Data.ByteString.Base16 as Base16
108110
import qualified Data.ByteString.Lazy as LBS
109111
import Data.ByteString.Short (ShortByteString)
110112
import qualified Data.ByteString.Short as SBS
@@ -150,8 +152,8 @@ import qualified Plutus.V1.Ledger.Examples as Plutus
150152

151153
import Cardano.Api.Eras
152154
import Cardano.Api.Error
153-
import Cardano.Api.HasTypeProxy
154155
import Cardano.Api.Hash
156+
import Cardano.Api.HasTypeProxy
155157
import Cardano.Api.KeysShelley
156158
import Cardano.Api.ScriptData
157159
import Cardano.Api.SerialiseCBOR
@@ -246,6 +248,11 @@ instance TestEquality SimpleScriptVersion where
246248
testEquality SimpleScriptV2 SimpleScriptV2 = Just Refl
247249
testEquality _ _ = Nothing
248250

251+
instance ToJSON (SimpleScriptVersion lang) where
252+
toJSON = \case
253+
SimpleScriptV1 -> Aeson.Number 1
254+
SimpleScriptV2 -> Aeson.Number 2
255+
249256

250257
data PlutusScriptVersion lang where
251258
PlutusScriptV1 :: PlutusScriptVersion PlutusScriptV1
@@ -259,6 +266,11 @@ instance TestEquality PlutusScriptVersion where
259266
testEquality PlutusScriptV2 PlutusScriptV2 = Just Refl
260267
testEquality _ _ = Nothing
261268

269+
instance ToJSON (PlutusScriptVersion lang) where
270+
toJSON = \case
271+
PlutusScriptV1 -> Aeson.Number 1
272+
PlutusScriptV2 -> Aeson.Number 2
273+
262274

263275
data AnyScriptLanguage where
264276
AnyScriptLanguage :: ScriptLanguage lang -> AnyScriptLanguage
@@ -468,6 +480,15 @@ instance IsScriptLanguage lang => HasTextEnvelope (Script lang) where
468480
PlutusScriptLanguage PlutusScriptV1 -> "PlutusScriptV1"
469481
PlutusScriptLanguage PlutusScriptV2 -> "PlutusScriptV2"
470482

483+
instance ToJSON (Script lang) where
484+
toJSON = \case
485+
SimpleScript version script ->
486+
object
487+
["type" .= ("simple" :: Text), "version" .= version, "script" .= script]
488+
PlutusScript version script ->
489+
object
490+
["type" .= ("plutus" :: Text), "version" .= version, "script" .= script]
491+
471492

472493
-- ----------------------------------------------------------------------------
473494
-- Scripts in any language
@@ -554,6 +575,10 @@ instance Eq (ScriptInEra era) where
554575
Nothing -> False
555576
Just Refl -> script == script'
556577

578+
instance ToJSON (ScriptInEra era) where
579+
toJSON (ScriptInEra language script) =
580+
object ["language" .= language, "script" .= script]
581+
557582

558583
data ScriptLanguageInEra lang era where
559584

@@ -1062,6 +1087,10 @@ instance (IsPlutusScriptLanguage lang, Typeable lang) =>
10621087
PlutusScriptV1 -> "PlutusScriptV1"
10631088
PlutusScriptV2 -> "PlutusScriptV2"
10641089

1090+
instance ToJSON (PlutusScript lang) where
1091+
toJSON (PlutusScriptSerialised bytes) =
1092+
object ["base16" .= Text.decodeUtf8 (Base16.encode $ SBS.fromShort bytes)]
1093+
10651094

10661095
-- | An example Plutus script that always succeeds, irrespective of inputs.
10671096
--

0 commit comments

Comments
 (0)