Skip to content

Commit

Permalink
Add conway era
Browse files Browse the repository at this point in the history
  • Loading branch information
klarkc committed Jan 16, 2024
1 parent 3f316ac commit 21ff698
Show file tree
Hide file tree
Showing 8 changed files with 103 additions and 37 deletions.
54 changes: 47 additions & 7 deletions src/Kupo/Data/Cardano.hs
Original file line number Diff line number Diff line change
Expand Up @@ -175,11 +175,8 @@ instance IsBlock Block where
foldrWithIndex (\ix -> fn ix . TransactionAlonzo) result (Ledger.fromTxSeq txs)
BlockBabbage (ShelleyBlock (Ledger.Block _ txs) _) ->
foldrWithIndex (\ix -> fn ix . TransactionBabbage) result (Ledger.fromTxSeq txs)
BlockConway{} ->
-- FIXME: Finalize once Conway is stable.
error "Ho no! Encountered a block from the Conway era. This era is not \
\supported by this version. Upgrade kupo to the latest version and \
\restart the process!"
BlockConway (ShelleyBlock (Ledger.Block _ txs) _) ->
foldrWithIndex (\ix -> fn ix . TransactionConway) result (Ledger.fromTxSeq txs)

spentInputs
:: Transaction
Expand All @@ -205,6 +202,12 @@ instance IsBlock Block where
tx ^. Ledger.bodyTxL . Ledger.inputsTxBodyL
Ledger.IsValid False ->
tx ^. Ledger.bodyTxL . Ledger.collateralInputsTxBodyL
TransactionConway tx ->
case tx ^. Ledger.isValidTxL of
Ledger.IsValid True ->
tx ^. Ledger.bodyTxL . Ledger.inputsTxBodyL
Ledger.IsValid False ->
tx ^. Ledger.bodyTxL . Ledger.collateralInputsTxBodyL
where
transformByron (Ledger.Byron.TxInUtxo txId ix) =
mkOutputReference
Expand Down Expand Up @@ -267,13 +270,34 @@ instance IsBlock Block where
in
case tx ^. Ledger.isValidTxL of
Ledger.IsValid True ->
traverseAndTransform identity txId meta 0 outs
traverseAndTransform fromBabbageOutput txId meta 0 outs
Ledger.IsValid False ->
-- From Babbage's formal specification:
--
-- Note that the new collOuts function generates a single output
-- with an index |txouts{txb}|.
let start = fromIntegral (length outs) in
case body ^. Ledger.collateralReturnTxBodyL of
SNothing ->
[]
SJust r ->
traverseAndTransform fromBabbageOutput txId meta start (r :<| mempty)
TransactionConway tx ->
let
body = tx ^. Ledger.bodyTxL
txId = Ledger.txid @(ConwayEra StandardCrypto) body
outs = body ^. Ledger.outputsTxBodyL
meta = tx ^. Ledger.auxDataTxL & strictMaybe emptyMetadata fromConwayMetadata
in
case tx ^. Ledger.isValidTxL of
Ledger.IsValid True ->
traverseAndTransform identity txId meta 0 outs
Ledger.IsValid False ->
-- From Conway formal specification:
--
-- Note that the new collOuts function generates a single output
-- with an index |txouts{txb}|.
let start = fromIntegral (length outs) in
case body ^. Ledger.collateralReturnTxBodyL of
SNothing ->
[]
Expand Down Expand Up @@ -337,6 +361,8 @@ instance IsBlock Block where
fromAlonzoData <$> Ledger.unTxDats (tx ^. Ledger.witsTxL . Ledger.datsTxWitsL)
TransactionBabbage tx ->
fromBabbageData <$> Ledger.unTxDats (tx ^. Ledger.witsTxL . Ledger.datsTxWitsL)
TransactionConway tx ->
fromConwayData <$> Ledger.unTxDats (tx ^. Ledger.witsTxL . Ledger.datsTxWitsL)

witnessedScripts
:: Transaction
Expand Down Expand Up @@ -364,7 +390,14 @@ instance IsBlock Block where
TransactionBabbage tx ->
( fromBabbageScript <$> (tx ^. Ledger.witsTxL . Ledger.scriptTxWitsL)
) & strictMaybe identity
(scriptFromAlonzoAuxiliaryData fromBabbageScript)
(scriptFromAlonzoAuxiliaryData identity)
(fromBabbageMetadata <$> tx ^. Ledger.auxDataTxL)
& scriptsFromOutputs
(fromBabbageOutput <$> tx ^. Ledger.bodyTxL . Ledger.outputsTxBodyL)
TransactionConway tx ->
( tx ^. Ledger.witsTxL . Ledger.scriptTxWitsL
) & strictMaybe identity
(scriptFromAlonzoAuxiliaryData identity)
(tx ^. Ledger.auxDataTxL)
& scriptsFromOutputs
(tx ^. Ledger.bodyTxL . Ledger.outputsTxBodyL)
Expand Down Expand Up @@ -410,3 +443,10 @@ instance IsBlock Block where
SJust auxData ->
let meta = fromBabbageMetadata auxData
in Just (hashMetadata meta, meta)
TransactionConway tx ->
case tx ^. Ledger.auxDataTxL of
SNothing ->
Nothing
SJust auxData ->
let meta = fromConwayMetadata auxData
in Just (hashMetadata meta, meta)
11 changes: 9 additions & 2 deletions src/Kupo/Data/Cardano/BinaryData.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,7 @@ import qualified Data.Aeson as Json
import qualified Data.Aeson.Encoding as Json

type BinaryData =
Ledger.BinaryData (BabbageEra StandardCrypto)
Ledger.BinaryData (ConwayEra StandardCrypto)

type BinaryDataHash =
DatumHash
Expand Down Expand Up @@ -65,6 +65,13 @@ fromBabbageData
:: Ledger.Data (BabbageEra StandardCrypto)
-> BinaryData
fromBabbageData =
Ledger.dataToBinaryData
Ledger.dataToBinaryData
. Ledger.upgradeData
{-# INLINEABLE fromBabbageData #-}

fromConwayData
:: Ledger.Data (ConwayEra StandardCrypto)
-> BinaryData
fromConwayData =
Ledger.dataToBinaryData
{-# INLINEABLE fromConwayData #-}
12 changes: 6 additions & 6 deletions src/Kupo/Data/Cardano/Datum.hs
Original file line number Diff line number Diff line change
Expand Up @@ -17,20 +17,20 @@ data Datum
| Inline !(Either DatumHash BinaryData)
deriving (Generic, Show, Eq, Ord)

toBabbageDatum
toConwayDatum
:: Datum
-> Ledger.Datum (BabbageEra StandardCrypto)
toBabbageDatum = \case
-> Ledger.Datum (ConwayEra StandardCrypto)
toConwayDatum = \case
NoDatum -> Ledger.NoDatum
Reference (Left ref) -> Ledger.DatumHash ref
Reference (Right bin) -> Ledger.Datum bin
Inline (Left ref) -> Ledger.DatumHash ref
Inline (Right bin) -> Ledger.Datum bin

fromBabbageDatum
:: Ledger.Datum (BabbageEra StandardCrypto)
fromConwayDatum
:: Ledger.Datum (ConwayEra StandardCrypto)
-> Datum
fromBabbageDatum = \case
fromConwayDatum = \case
Ledger.NoDatum -> NoDatum
Ledger.DatumHash ref -> Reference (Left ref)
Ledger.Datum bin -> Inline (Right bin)
Expand Down
9 changes: 7 additions & 2 deletions src/Kupo/Data/Cardano/Metadata.hs
Original file line number Diff line number Diff line change
Expand Up @@ -41,7 +41,7 @@ import qualified Data.Text as T
import qualified Data.Text.Read as T

type Metadata =
AlonzoTxAuxData (BabbageEra StandardCrypto)
AlonzoTxAuxData (ConwayEra StandardCrypto)

emptyMetadata :: Metadata
emptyMetadata =
Expand Down Expand Up @@ -182,5 +182,10 @@ fromAlonzoMetadata =

fromBabbageMetadata :: AlonzoTxAuxData (BabbageEra StandardCrypto) -> Metadata
fromBabbageMetadata =
identity
Ledger.upgradeTxAuxData
{-# INLINABLE fromBabbageMetadata #-}

fromConwayMetadata :: AlonzoTxAuxData (ConwayEra StandardCrypto) -> Metadata
fromConwayMetadata =
identity
{-# INLINABLE fromConwayMetadata #-}
2 changes: 1 addition & 1 deletion src/Kupo/Data/Cardano/NativeScript.hs
Original file line number Diff line number Diff line change
Expand Up @@ -19,4 +19,4 @@ import Cardano.Ledger.Keys

import qualified Cardano.Ledger.Allegra.Scripts as Ledger.Allegra

type NativeScript = Ledger.Allegra.Timelock (BabbageEra StandardCrypto)
type NativeScript = Ledger.Allegra.Timelock (ConwayEra StandardCrypto)
34 changes: 18 additions & 16 deletions src/Kupo/Data/Cardano/Output.hs
Original file line number Diff line number Diff line change
Expand Up @@ -17,13 +17,12 @@ import Kupo.Data.Cardano.Address
)
import Kupo.Data.Cardano.Datum
( Datum
, fromBabbageDatum
, toBabbageDatum
, fromConwayDatum
, toConwayDatum
)
import Kupo.Data.Cardano.Script
( ComparableScript
, Script
, fromComparableScript
, hashScript
, toComparableScript
)
Expand All @@ -33,7 +32,6 @@ import Kupo.Data.Cardano.ScriptHash
import Kupo.Data.Cardano.Value
( ComparableValue
, Value
, fromComparableValue
, toComparableValue
)

Expand All @@ -43,6 +41,7 @@ import qualified Cardano.Ledger.Address as Ledger
import qualified Cardano.Ledger.Alonzo.TxBody as Ledger.Alonzo
import qualified Cardano.Ledger.Babbage.TxBody as Ledger.Babbage
import qualified Cardano.Ledger.Coin as Ledger
import qualified Cardano.Ledger.Conway as Ledger.Conway
import qualified Cardano.Ledger.Core as Ledger.Core
import qualified Cardano.Ledger.Mary.Value as Ledger
import qualified Cardano.Ledger.Shelley.Tx as Ledger.Shelley
Expand All @@ -55,7 +54,7 @@ type Output =
Output' StandardCrypto

type Output' crypto =
Ledger.Babbage.BabbageTxOut (BabbageEra crypto)
Ledger.Babbage.BabbageTxOut (ConwayEra crypto)

mkOutput
:: Address
Expand All @@ -67,7 +66,7 @@ mkOutput address value datum script =
Ledger.Babbage.BabbageTxOut
address
value
(toBabbageDatum datum)
(toConwayDatum datum)
(maybeToStrictMaybe script)
{-# INLINABLE mkOutput #-}

Expand All @@ -76,7 +75,7 @@ fromByronOutput
( Crypto crypto
)
=> Ledger.Byron.TxOut
-> Ledger.Core.TxOut (BabbageEra crypto)
-> Output' crypto
fromByronOutput (Ledger.Byron.TxOut address value) =
Ledger.Babbage.BabbageTxOut
(Ledger.AddrBootstrap (Ledger.BootstrapAddress address))
Expand All @@ -94,7 +93,7 @@ fromShelleyOutput
)
=> (Ledger.Core.Value (era crypto) -> Ledger.MaryValue crypto)
-> Ledger.Core.TxOut (era crypto)
-> Ledger.Core.TxOut (BabbageEra crypto)
-> Output' crypto
fromShelleyOutput liftValue (Ledger.Shelley.ShelleyTxOut addr value) =
Ledger.Babbage.BabbageTxOut addr (liftValue value) Ledger.Babbage.NoDatum SNothing
{-# INLINABLE fromShelleyOutput #-}
Expand All @@ -104,7 +103,7 @@ fromAlonzoOutput
( Crypto crypto
)
=> Ledger.Core.TxOut (AlonzoEra crypto)
-> Ledger.Core.TxOut (BabbageEra crypto)
-> Output' crypto
fromAlonzoOutput (Ledger.Alonzo.AlonzoTxOut addr value datum) =
case datum of
SNothing ->
Expand All @@ -121,6 +120,15 @@ fromAlonzoOutput (Ledger.Alonzo.AlonzoTxOut addr value datum) =
(Ledger.Babbage.DatumHash datumHash)
SNothing

fromBabbageOutput
:: forall crypto.
( Crypto crypto
)
=> Ledger.Core.TxOut (BabbageEra crypto)
-> Output' crypto
fromBabbageOutput = Ledger.Core.upgradeTxOut
{-# INLINABLE fromBabbageOutput #-}

getAddress
:: Output
-> Address
Expand All @@ -139,7 +147,7 @@ getDatum
:: Output
-> Datum
getDatum (Ledger.Babbage.BabbageTxOut _address _value datum _refScript) =
fromBabbageDatum datum
fromConwayDatum datum
{-# INLINABLE getDatum #-}

getScript
Expand Down Expand Up @@ -182,9 +190,3 @@ toComparableOutput out = ComparableOutput
, comparableOutputDatum = getDatum out
, comparableOutputScript = toComparableScript <$> getScript out
}

fromComparableOutput
:: ComparableOutput
-> Output
fromComparableOutput (ComparableOutput addr val datum script) =
mkOutput addr (fromComparableValue val) datum (fromComparableScript <$> script)
13 changes: 10 additions & 3 deletions src/Kupo/Data/Cardano/Script.hs
Original file line number Diff line number Diff line change
Expand Up @@ -39,7 +39,7 @@ import qualified Data.ByteString as BS
import qualified Data.Map as Map

type Script =
Ledger.Alonzo.Script (BabbageEra StandardCrypto)
Ledger.Alonzo.Script (ConwayEra StandardCrypto)

scriptFromAllegraAuxiliaryData
:: forall era.
Expand Down Expand Up @@ -100,9 +100,16 @@ fromBabbageScript
:: Ledger.Alonzo.Script (BabbageEra StandardCrypto)
-> Script
fromBabbageScript =
identity
Ledger.Core.upgradeScript
{-# INLINABLE fromBabbageScript #-}

fromConwayScript
:: Ledger.Alonzo.Script (ConwayEra StandardCrypto)
-> Script
fromConwayScript =
identity
{-# INLINABLE fromConwayScript #-}

scriptToJson
:: Script
-> Json.Encoding
Expand Down Expand Up @@ -169,7 +176,7 @@ hashScript
:: Script
-> ScriptHash
hashScript =
Ledger.Core.hashScript @(BabbageEra StandardCrypto)
Ledger.Core.hashScript @(ConwayEra StandardCrypto)
{-# INLINABLE hashScript #-}

newtype ComparableScript = ComparableScript { unComparableScript :: Script }
Expand Down
5 changes: 5 additions & 0 deletions src/Kupo/Data/Cardano/Transaction.hs
Original file line number Diff line number Diff line change
Expand Up @@ -31,6 +31,8 @@ data Transaction' crypto
!(Ledger.Alonzo.AlonzoTx (AlonzoEra crypto))
| TransactionBabbage
!(Ledger.Alonzo.AlonzoTx (BabbageEra crypto))
| TransactionConway
!(Ledger.Alonzo.AlonzoTx (ConwayEra crypto))

instance HasTransactionId Transaction StandardCrypto where
getTransactionId = \case
Expand All @@ -51,3 +53,6 @@ instance HasTransactionId Transaction StandardCrypto where
TransactionBabbage tx ->
let body = Ledger.Alonzo.body tx
in Ledger.txid @(BabbageEra StandardCrypto) body
TransactionConway tx ->
let body = Ledger.Alonzo.body tx
in Ledger.txid @(ConwayEra StandardCrypto) body

0 comments on commit 21ff698

Please sign in to comment.