diff --git a/.gitignore b/.gitignore index fed013a9..933cf2df 100644 --- a/.gitignore +++ b/.gitignore @@ -23,3 +23,7 @@ dist-newstyle ## Claude Code (symlink created by the devShell shellHook) /.claude + +## Local dev scripts (patch-nix-deps.sh stays tracked) +/scripts/* +!/scripts/patch-nix-deps.sh diff --git a/cabal.project b/cabal.project index f5819126..18fa691a 100644 --- a/cabal.project +++ b/cabal.project @@ -10,8 +10,8 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee index-state: - , hackage.haskell.org 2026-05-08T22:40:19Z - , cardano-haskell-packages 2026-05-08T13:26:45Z + , hackage.haskell.org 2026-08-14T13:38:07Z + , cardano-haskell-packages 2026-09-16T23:53:07Z packages: ./ @@ -46,16 +46,15 @@ package direct-sqlite flags: +nomutex constraints: - , any.cardano-node == 11.0.1 + , any.cardano-node == 11.1.1 - , any.cardano-ledger-conway >= 1.22.1.0 + , any.cardano-ledger-conway >= 1.23 - , any.ouroboros-consensus ^>= 3.0.1 - , any.ouroboros-network ^>= 1.1 + , any.ouroboros-consensus ^>= 4.2.1 + , any.ouroboros-network ^>= 1.2 , any.io-classes ^>= 1.8 , any.formatting == 7.2.0 - , any.validation < 1.2 , any.text source -- Use serial block IO instead of io_uring to avoid requiring liburing @@ -71,14 +70,16 @@ allow-newer: , io-classes:time -- NOTE update hash using --- nix-prefetch-git https://github.com/CardanoSolutions/ogmios.git --rev --fetch-submodules --quiet | jq '.hash' | tail -c +9 | head -c -2 +-- nix-prefetch-git https://github.com/IntersectMBO/ogmios.git --rev --fetch-submodules --quiet | jq '.hash' | tail -c +9 | head -c -2 +-- source-repository-package type: git - location: https://github.com/CardanoSolutions/ogmios - --sha256: xkOfOdX6Dxi7+VW78Tk3n3MoguIg39pKdxiNVfdeEwE= - tag: ae876badb138f42dcd6d2389734b0c15502684ed + location: https://github.com/IntersectMBO/ogmios + --sha256: sha256-1VptE6HSuT2U+NMw7HLb5X1PqqrYpsOkl4tWHk5ygG4= + tag: ed9efbad7b06193b00c13fb8102dcd0d8ff63647 subdir: server/modules/fast-bech32 + server/modules/contra-tracers source-repository-package type: git diff --git a/flake.lock b/flake.lock index b2d430a6..cd1994ea 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1778248807, - "narHash": "sha256-LI4R+Yl7cy9uO/jWXpo93mUyVMR/UhOoDFVbHV7/abw=", + "lastModified": 1790211900, + "narHash": "sha256-o/e7qqnyMNMEht+0yZiGQQ6EhE9opeiSSvvxa8CYUy4=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "61c9835abcfc3a6c9b6279226d4502fa877bb6a7", + "rev": "315bf143ebaaaefdb3917131d6cb08e8d35a8178", "type": "github" }, "original": { @@ -171,11 +171,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1779824738, - "narHash": "sha256-o4W05VYZ0hlIA/BXxL6hYsQ9HL6JsawxepFnCh429R8=", + "lastModified": 1790350404, + "narHash": "sha256-gAkFrvMBN1Zbj5LzBkqaTpmi4q4CjSFsx8MZk4SPlk0=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "decbe184cfce30ea802ea95c874511f776a4b48a", + "rev": "7ccc0d13ae4744e9795964070eabc0a50da7e4bd", "type": "github" }, "original": { diff --git a/kupo.cabal b/kupo.cabal index 5b707082..39f9adc6 100644 --- a/kupo.cabal +++ b/kupo.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 --- This file has been generated from package.yaml by hpack version 0.38.2. +-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack @@ -131,6 +131,8 @@ library Kupo.Version.TH other-modules: Paths_kupo + autogen-modules: + Paths_kupo hs-source-dirs: src default-extensions: @@ -184,6 +186,8 @@ library , bytestring , cardano-crypto-class , cardano-crypto-wrapper + , cardano-data + , cardano-diffusion , cardano-ledger-allegra , cardano-ledger-alonzo , cardano-ledger-api @@ -192,6 +196,7 @@ library , cardano-ledger-byron , cardano-ledger-conway , cardano-ledger-core + , cardano-ledger-dijkstra , cardano-ledger-mary , cardano-ledger-shelley , cardano-slotting @@ -215,7 +220,6 @@ library , network , network-mux , optparse-applicative - , cardano-diffusion , ouroboros-consensus , ouroboros-consensus:cardano , ouroboros-consensus:diffusion @@ -256,6 +260,8 @@ executable kupo main-is: Main.hs other-modules: Paths_kupo + autogen-modules: + Paths_kupo hs-source-dirs: app default-extensions: @@ -333,6 +339,8 @@ test-suite unit Test.Kupo.OptionsSpec Test.KupoSpec Paths_kupo + autogen-modules: + Paths_kupo hs-source-dirs: test default-extensions: @@ -389,6 +397,7 @@ test-suite unit , http-media , http-types , io-classes + , io-classes:si-timers , io-sim , kupo , lens-aeson @@ -396,7 +405,6 @@ test-suite unit , process , quickcheck-state-machine , relude - , io-classes:si-timers , sqlite-simple , stm , temporary diff --git a/package.yaml b/package.yaml index 307c932d..9868d9d8 100644 --- a/package.yaml +++ b/package.yaml @@ -63,6 +63,7 @@ library: - bytestring - cardano-crypto-class - cardano-crypto-wrapper + - cardano-data - cardano-ledger-allegra - cardano-ledger-alonzo - cardano-ledger-api @@ -71,6 +72,7 @@ library: - cardano-ledger-byron - cardano-ledger-conway - cardano-ledger-core + - cardano-ledger-dijkstra - cardano-ledger-mary - cardano-ledger-shelley - cardano-slotting diff --git a/src/Kupo/Control/MonadLog.hs b/src/Kupo/Control/MonadLog.hs index d89f4bbe..a21efd99 100644 --- a/src/Kupo/Control/MonadLog.hs +++ b/src/Kupo/Control/MonadLog.hs @@ -41,6 +41,7 @@ import Control.Monad.Class.MonadTime ) import Control.Tracer ( Tracer (..) + , mkTracer , natTracer , nullTracer , traceWith @@ -135,7 +136,7 @@ withTracers h version tracers action = do :: Writer -> TMVar IO () -> Tracer IO SomeMsg - tracer say lock = Tracer $ \someMsg@(SomeMsg minSeverity _ msg) -> do + tracer say lock = mkTracer $ \someMsg@(SomeMsg minSeverity _ msg) -> do let severity = getSeverityAnnotation msg when (severity >= minSeverity) $ liftIO $ withTMVar lock $ \() -> do threadId <- myThreadId diff --git a/src/Kupo/Data/Cardano.hs b/src/Kupo/Data/Cardano.hs index 010b6323..59bcbd7e 100644 --- a/src/Kupo/Data/Cardano.hs +++ b/src/Kupo/Data/Cardano.hs @@ -102,6 +102,8 @@ import qualified Cardano.Ledger.Alonzo.Core as Ledger import qualified Cardano.Ledger.Alonzo.TxWits as Ledger import qualified Cardano.Ledger.Babbage.Core as Ledger import qualified Cardano.Ledger.Block as Ledger +import qualified Cardano.Ledger.Dijkstra.Core as Ledger +import qualified Data.OMap.Strict as OMap import qualified Data.Set as Set -- IsBlock @@ -194,9 +196,26 @@ instance IsBlock Block where foldrWithIndex (\ix -> fn ix . TransactionBabbage) result (txs ^. Ledger.txSeqBlockBodyL) BlockConway (ShelleyBlock (Ledger.Block _ txs) _) -> foldrWithIndex (\ix -> fn ix . TransactionConway) result (txs ^. Ledger.txSeqBlockBodyL) - BlockDijkstra _ -> - -- We don't support Dijkstra blocks. - error "kupo: Dijkstra blocks are not supported." + BlockDijkstra (ShelleyBlock (Ledger.Block _ txs) _) -> + foldrWithIndex (\ix -> fn ix . TransactionDijkstra . rejectSubTransactions) result (txs ^. Ledger.txSeqBlockBodyL) + where + -- Dijkstra introduces nested transactions: a top-level transaction may + -- carry sub-transactions, each with its own id, inputs and outputs but + -- no phase-2 validity flag or collateral of its own. Kupo folds one flat + -- sequence of transactions per block and stores the resulting index on + -- every output reference, so how sub-transactions are numbered (and how + -- a phase-2 invalid parent affects them) is a design decision that has + -- not been made yet. Until it is, fail loudly rather than silently + -- dropping their inputs and outputs from the index. + rejectSubTransactions + :: Ledger.Tx Ledger.TopTx DijkstraEra + -> Ledger.Tx Ledger.TopTx DijkstraEra + rejectSubTransactions tx + | OMap.null (tx ^. Ledger.bodyTxL . Ledger.subTransactionsTxBodyL) = + tx + | otherwise = + error $ "kupo: Dijkstra transaction " <> show (Ledger.txIdTx @DijkstraEra tx) + <> " carries sub-transactions, which kupo does not index yet." spentInputs :: Transaction @@ -211,22 +230,28 @@ instance IsBlock Block where TransactionMary tx -> tx ^. Ledger.bodyTxL . Ledger.inputsTxBodyL TransactionAlonzo tx -> - case tx ^. Ledger.isValidTxL of - Ledger.IsValid True -> + case tx ^. Ledger.isPhase2ValidTxL of + Ledger.Phase2Valid -> tx ^. Ledger.bodyTxL . Ledger.inputsTxBodyL - Ledger.IsValid False -> + Ledger.Phase2Invalid -> tx ^. Ledger.bodyTxL . Ledger.collateralInputsTxBodyL TransactionBabbage tx -> - case tx ^. Ledger.isValidTxL of - Ledger.IsValid True -> + case tx ^. Ledger.isPhase2ValidTxL of + Ledger.Phase2Valid -> tx ^. Ledger.bodyTxL . Ledger.inputsTxBodyL - Ledger.IsValid False -> + Ledger.Phase2Invalid -> tx ^. Ledger.bodyTxL . Ledger.collateralInputsTxBodyL TransactionConway tx -> - case tx ^. Ledger.isValidTxL of - Ledger.IsValid True -> + case tx ^. Ledger.isPhase2ValidTxL of + Ledger.Phase2Valid -> + tx ^. Ledger.bodyTxL . Ledger.inputsTxBodyL + Ledger.Phase2Invalid -> + tx ^. Ledger.bodyTxL . Ledger.collateralInputsTxBodyL + TransactionDijkstra tx -> + case tx ^. Ledger.isPhase2ValidTxL of + Ledger.Phase2Valid -> tx ^. Ledger.bodyTxL . Ledger.inputsTxBodyL - Ledger.IsValid False -> + Ledger.Phase2Invalid -> tx ^. Ledger.bodyTxL . Ledger.collateralInputsTxBodyL where transformByron (Ledger.Byron.TxInUtxo txId ix) = @@ -276,10 +301,10 @@ instance IsBlock Block where outs = body ^. Ledger.outputsTxBodyL meta = tx ^. Ledger.auxDataTxL & strictMaybe emptyMetadata fromAlonzoMetadata in - case tx ^. Ledger.isValidTxL of - Ledger.IsValid True -> + case tx ^. Ledger.isPhase2ValidTxL of + Ledger.Phase2Valid -> traverseAndTransform fromAlonzoOutput txId meta 0 outs - Ledger.IsValid False -> + Ledger.Phase2Invalid -> [] TransactionBabbage tx -> let @@ -288,10 +313,10 @@ instance IsBlock Block where outs = body ^. Ledger.outputsTxBodyL meta = tx ^. Ledger.auxDataTxL & strictMaybe emptyMetadata fromBabbageMetadata in - case tx ^. Ledger.isValidTxL of - Ledger.IsValid True -> + case tx ^. Ledger.isPhase2ValidTxL of + Ledger.Phase2Valid -> traverseAndTransform fromBabbageOutput txId meta 0 outs - Ledger.IsValid False -> + Ledger.Phase2Invalid -> -- From Babbage's formal specification: -- -- Note that the new collOuts function generates a single output @@ -309,14 +334,31 @@ instance IsBlock Block where 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 -> + case tx ^. Ledger.isPhase2ValidTxL of + Ledger.Phase2Valid -> + traverseAndTransform fromConwayOutput txId meta 0 outs + Ledger.Phase2Invalid -> -- 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 -> + [] + SJust r -> + traverseAndTransform fromConwayOutput txId meta start (r :<| mempty) + TransactionDijkstra tx -> + let + body = tx ^. Ledger.bodyTxL + txId = Ledger.txIdTxBody @DijkstraEra body + outs = body ^. Ledger.outputsTxBodyL + meta = tx ^. Ledger.auxDataTxL & strictMaybe emptyMetadata identity + in + case tx ^. Ledger.isPhase2ValidTxL of + Ledger.Phase2Valid -> + traverseAndTransform identity txId meta 0 outs + Ledger.Phase2Invalid -> let start = fromIntegral (length outs) in case body ^. Ledger.collateralReturnTxBodyL of SNothing -> @@ -383,6 +425,8 @@ instance IsBlock Block where fromBabbageData <$> Ledger.unTxDats (tx ^. Ledger.witsTxL . Ledger.datsTxWitsL) TransactionConway tx -> fromConwayData <$> Ledger.unTxDats (tx ^. Ledger.witsTxL . Ledger.datsTxWitsL) + TransactionDijkstra tx -> + fromDijkstraData <$> Ledger.unTxDats (tx ^. Ledger.witsTxL . Ledger.datsTxWitsL) witnessedScripts :: Transaction @@ -415,6 +459,13 @@ instance IsBlock Block where & scriptsFromOutputs (fromBabbageOutput <$> tx ^. Ledger.bodyTxL . Ledger.outputsTxBodyL) TransactionConway tx -> + ( fromConwayScript <$> tx ^. Ledger.witsTxL . Ledger.scriptTxWitsL + ) & strictMaybe identity + (scriptFromAlonzoAuxiliaryData fromConwayScript) + (tx ^. Ledger.auxDataTxL) + & scriptsFromOutputs + (fromConwayOutput <$> tx ^. Ledger.bodyTxL . Ledger.outputsTxBodyL) + TransactionDijkstra tx -> ( tx ^. Ledger.witsTxL . Ledger.scriptTxWitsL ) & strictMaybe identity (scriptFromAlonzoAuxiliaryData identity) @@ -470,6 +521,12 @@ instance IsBlock Block where SJust auxData -> let meta = fromConwayMetadata auxData in Just (hashMetadata meta, meta) + TransactionDijkstra tx -> + case tx ^. Ledger.auxDataTxL of + SNothing -> + Nothing + SJust auxData -> + Just (hashMetadata auxData, auxData) spendRedeemer :: Transaction @@ -491,3 +548,5 @@ instance IsBlock Block where Just (RedeemersBabbage (tx ^. Ledger.witsTxL . Ledger.rdmrsTxWitsL)) TransactionConway tx -> Just (RedeemersConway (tx ^. Ledger.witsTxL . Ledger.rdmrsTxWitsL)) + TransactionDijkstra tx -> + Just (RedeemersDisjkstra (tx ^. Ledger.witsTxL . Ledger.rdmrsTxWitsL)) diff --git a/src/Kupo/Data/Cardano/BinaryData.hs b/src/Kupo/Data/Cardano/BinaryData.hs index fae48be1..b500b3c2 100644 --- a/src/Kupo/Data/Cardano/BinaryData.hs +++ b/src/Kupo/Data/Cardano/BinaryData.hs @@ -12,7 +12,7 @@ import qualified Data.Aeson as Json import qualified Data.Aeson.Encoding as Json type BinaryData = - Ledger.BinaryData ConwayEra + Ledger.BinaryData DijkstraEra type BinaryDataHash = DatumHash @@ -66,6 +66,7 @@ fromBabbageData -> BinaryData fromBabbageData = Ledger.dataToBinaryData + . (Ledger.upgradeData :: Ledger.Data ConwayEra -> Ledger.Data DijkstraEra) . Ledger.upgradeData {-# INLINEABLE fromBabbageData #-} @@ -73,5 +74,12 @@ fromConwayData :: Ledger.Data ConwayEra -> BinaryData fromConwayData = - Ledger.dataToBinaryData + Ledger.dataToBinaryData . Ledger.upgradeData {-# INLINEABLE fromConwayData #-} + +fromDijkstraData + :: Ledger.Data DijkstraEra + -> BinaryData +fromDijkstraData = + Ledger.dataToBinaryData +{-# INLINEABLE fromDijkstraData #-} diff --git a/src/Kupo/Data/Cardano/Datum.hs b/src/Kupo/Data/Cardano/Datum.hs index d4de93a3..db9788db 100644 --- a/src/Kupo/Data/Cardano/Datum.hs +++ b/src/Kupo/Data/Cardano/Datum.hs @@ -18,24 +18,25 @@ data Datum | Inline !(Either DatumHash BinaryData) deriving (Generic, Show, Eq, Ord) -toConwayDatum + +fromDijkstraDatum + :: Ledger.Datum DijkstraEra + -> Datum +fromDijkstraDatum = \case + Ledger.NoDatum -> NoDatum + Ledger.DatumHash ref -> Reference (Left ref) + Ledger.Datum bin -> Inline (Right bin) + +toDijkstraDatum :: Datum - -> Ledger.Datum ConwayEra -toConwayDatum = \case + -> Ledger.Datum DijkstraEra +toDijkstraDatum = \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 -fromConwayDatum - :: Ledger.Datum ConwayEra - -> Datum -fromConwayDatum = \case - Ledger.NoDatum -> NoDatum - Ledger.DatumHash ref -> Reference (Left ref) - Ledger.Datum bin -> Inline (Right bin) - getBinaryData :: Datum -> Maybe BinaryData diff --git a/src/Kupo/Data/Cardano/HeaderHash.hs b/src/Kupo/Data/Cardano/HeaderHash.hs index d2fa347e..25dd6892 100644 --- a/src/Kupo/Data/Cardano/HeaderHash.hs +++ b/src/Kupo/Data/Cardano/HeaderHash.hs @@ -62,5 +62,5 @@ unsafeHeaderHashFromBytes :: ByteString -> HeaderHash Block unsafeHeaderHashFromBytes = - fromRawHash (Proxy @Block) + unsafeFromRawHash (Proxy @Block) {-# INLINABLE unsafeHeaderHashFromBytes #-} diff --git a/src/Kupo/Data/Cardano/Metadata.hs b/src/Kupo/Data/Cardano/Metadata.hs index 0a94a9a5..95be51b0 100644 --- a/src/Kupo/Data/Cardano/Metadata.hs +++ b/src/Kupo/Data/Cardano/Metadata.hs @@ -5,6 +5,10 @@ module Kupo.Data.Cardano.Metadata import Kupo.Prelude +import Data.Array.Byte + ( ByteArray + ) + import Cardano.Ledger.Allegra.TxAuxData ( AllegraTxAuxData (..) ) @@ -29,18 +33,20 @@ import Ouroboros.Consensus.Util import qualified Cardano.Ledger.Allegra.Scripts as Ledger.Allegra import qualified Cardano.Ledger.Api.Era as Ledger import qualified Cardano.Ledger.Core as Ledger +import qualified Cardano.Ledger.Dijkstra.Scripts as Ledger.Dijkstra import qualified Cardano.Ledger.Shelley.TxAuxData as Ledger import qualified Data.Aeson as Json import qualified Data.Aeson.Encoding as Json import qualified Data.Aeson.Key as Json.Key import qualified Data.Aeson.KeyMap as Json.KeyMap import qualified Data.Aeson.Types as Json +import qualified Data.ByteString.Short.Internal as SBS import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.Read as T type Metadata = - AlonzoTxAuxData ConwayEra + AlonzoTxAuxData DijkstraEra emptyMetadata :: Metadata emptyMetadata = @@ -68,7 +74,7 @@ metadataToText = metadataFromText :: Text -> Maybe Metadata metadataFromText txt = do bytes <- eitherToMaybe $ decodeBase16 (encodeUtf8 txt) - eitherToMaybe $ decodeCborAnn @ConwayEra "Metadata" decCBOR (toLazy bytes) + eitherToMaybe $ decodeCborAnn @DijkstraEra "Metadata" decCBOR (toLazy bytes) metadataToJson :: Metadata -> Json.Encoding metadataToJson (AlonzoTxAuxData labels _ _) = @@ -81,7 +87,7 @@ metadataToJson (AlonzoTxAuxData labels _ _) = Ledger.S txt -> encodeObject [("string", Json.text txt)] Ledger.B bytes -> - encodeObject [("bytes", Json.text $ encodeBase16 bytes)] + encodeObject [("bytes", Json.text $ encodeBase16 (byteArrayToByteString bytes))] Ledger.List xs -> encodeObject [("list", Json.list encodeMetadatum xs)] Ledger.Map xs -> @@ -134,7 +140,7 @@ metadataFromJson = fmap mkMetadata . Json.withObject "Metadata" metadatumBytesFromJson o = do b <- (o .: "bytes") >>= either (fail . toString) pure . decodeBase16 . encodeUtf8 @Text - pure (Ledger.B b) + pure (Ledger.B (byteStringToByteArray b)) metadatumListFromJson :: Json.Object -> Json.Parser Metadatum metadatumListFromJson o = do @@ -166,25 +172,37 @@ fromShelleyMetadata (ShelleyTxAuxData labels) = fromAllegraMetadata :: AllegraTxAuxData AllegraEra -> Metadata fromAllegraMetadata (AllegraTxAuxData labels timelocks) = - AlonzoTxAuxData labels (Ledger.Allegra.translateTimelock <$> timelocks) mempty + AlonzoTxAuxData labels (Ledger.Dijkstra.upgradeTimelock . Ledger.Allegra.translateTimelock <$> timelocks) mempty {-# INLINABLE fromAllegraMetadata #-} fromMaryMetadata :: AllegraTxAuxData MaryEra -> Metadata fromMaryMetadata (AllegraTxAuxData labels timelocks) = - AlonzoTxAuxData labels (Ledger.Allegra.translateTimelock <$> timelocks) mempty + AlonzoTxAuxData labels (Ledger.Dijkstra.upgradeTimelock . Ledger.Allegra.translateTimelock <$> timelocks) mempty {-# INLINABLE fromMaryMetadata #-} fromAlonzoMetadata :: AlonzoTxAuxData AlonzoEra -> Metadata fromAlonzoMetadata = - Ledger.upgradeTxAuxData . Ledger.upgradeTxAuxData + fromConwayMetadata . Ledger.upgradeTxAuxData . Ledger.upgradeTxAuxData {-# INLINABLE fromAlonzoMetadata #-} fromBabbageMetadata :: AlonzoTxAuxData BabbageEra -> Metadata fromBabbageMetadata = - Ledger.upgradeTxAuxData + fromConwayMetadata . Ledger.upgradeTxAuxData {-# INLINABLE fromBabbageMetadata #-} fromConwayMetadata :: AlonzoTxAuxData ConwayEra -> Metadata -fromConwayMetadata = - identity +fromConwayMetadata (AlonzoTxAuxData labels timelocks plutus) = + AlonzoTxAuxData labels (Ledger.Dijkstra.upgradeTimelock <$> timelocks) plutus {-# INLINABLE fromConwayMetadata #-} + +-- +-- Helpers +-- + +-- | Converting between 'ByteArray' (unpinned) and 'ByteString' (pinned) copies the +-- bytes. Harmless: the ledger caps metadata byte strings at 64 bytes. +byteArrayToByteString :: ByteArray -> ByteString +byteArrayToByteString = fromShort . SBS.ShortByteString + +byteStringToByteArray :: ByteString -> ByteArray +byteStringToByteArray = SBS.unShortByteString . toShort diff --git a/src/Kupo/Data/Cardano/NativeScript.hs b/src/Kupo/Data/Cardano/NativeScript.hs index 76d9dca6..3283f8b1 100644 --- a/src/Kupo/Data/Cardano/NativeScript.hs +++ b/src/Kupo/Data/Cardano/NativeScript.hs @@ -18,6 +18,7 @@ import Cardano.Ledger.Keys ) import qualified Cardano.Ledger.Allegra.Scripts as Ledger.Allegra +import qualified Cardano.Ledger.Dijkstra.Scripts as Ledger.Dijkstra import qualified Cardano.Ledger.Shelley.Scripts as Ledger.Shelley -type NativeScript = Ledger.Allegra.Timelock ConwayEra +type NativeScript = Ledger.Dijkstra.DijkstraNativeScript DijkstraEra diff --git a/src/Kupo/Data/Cardano/Output.hs b/src/Kupo/Data/Cardano/Output.hs index c51bf076..af34b6ac 100644 --- a/src/Kupo/Data/Cardano/Output.hs +++ b/src/Kupo/Data/Cardano/Output.hs @@ -17,8 +17,8 @@ import Kupo.Data.Cardano.Address ) import Kupo.Data.Cardano.Datum ( Datum - , fromConwayDatum - , toConwayDatum + , fromDijkstraDatum + , toDijkstraDatum ) import Kupo.Data.Cardano.Script ( ComparableScript @@ -53,7 +53,7 @@ import qualified Data.Map as Map -- Output type Output = - Ledger.Babbage.BabbageTxOut ConwayEra + Ledger.Babbage.BabbageTxOut DijkstraEra mkOutput :: Address @@ -65,7 +65,7 @@ mkOutput address value datum script = Ledger.Babbage.BabbageTxOut address value - (toConwayDatum datum) + (toDijkstraDatum datum) (maybeToStrictMaybe script) {-# INLINABLE mkOutput #-} @@ -116,9 +116,16 @@ fromBabbageOutput :: Ledger.Core.TxOut BabbageEra -> Output fromBabbageOutput = - Ledger.Core.upgradeTxOut + Ledger.Core.upgradeTxOut . Ledger.Core.upgradeTxOut {-# INLINABLE fromBabbageOutput #-} +fromConwayOutput + :: Ledger.Core.TxOut ConwayEra + -> Output +fromConwayOutput = + Ledger.Core.upgradeTxOut +{-# INLINABLE fromConwayOutput #-} + getAddress :: Output -> Address @@ -137,7 +144,7 @@ getDatum :: Output -> Datum getDatum (Ledger.Babbage.BabbageTxOut _address _value datum _refScript) = - fromConwayDatum datum + fromDijkstraDatum datum {-# INLINABLE getDatum #-} getScript diff --git a/src/Kupo/Data/Cardano/Redeemers.hs b/src/Kupo/Data/Cardano/Redeemers.hs index 55d70806..fc985c76 100644 --- a/src/Kupo/Data/Cardano/Redeemers.hs +++ b/src/Kupo/Data/Cardano/Redeemers.hs @@ -7,6 +7,7 @@ import Kupo.Data.Cardano.BinaryData , fromAlonzoData , fromBabbageData , fromConwayData + , fromDijkstraData ) import Kupo.Data.Cardano.OutputIndex ( InputIndex @@ -15,12 +16,14 @@ import Kupo.Data.Cardano.OutputIndex import qualified Cardano.Ledger.Alonzo.Scripts as Ledger import qualified Cardano.Ledger.Alonzo.TxWits as Ledger import qualified Cardano.Ledger.Conway.Scripts as Ledger +import qualified Cardano.Ledger.Dijkstra.Scripts as Ledger import qualified Data.Map as Map data Redeemers = RedeemersAlonzo (Ledger.Redeemers AlonzoEra) | RedeemersBabbage (Ledger.Redeemers BabbageEra) | RedeemersConway (Ledger.Redeemers ConwayEra) + | RedeemersDisjkstra (Ledger.Redeemers DijkstraEra) lookupSpendRedeemer :: InputIndex @@ -36,3 +39,6 @@ lookupSpendRedeemer ix = \case RedeemersConway (Ledger.Redeemers redeemers) -> let purpose = Ledger.ConwaySpending (Ledger.AsIx (fromIntegral ix)) in fromConwayData . fst <$> Map.lookup purpose redeemers + RedeemersDisjkstra (Ledger.Redeemers redeemers) -> + let purpose = Ledger.DijkstraSpending (Ledger.AsIx (fromIntegral ix)) + in fromDijkstraData . fst <$> Map.lookup purpose redeemers diff --git a/src/Kupo/Data/Cardano/Script.hs b/src/Kupo/Data/Cardano/Script.hs index 8b04a94f..bf7ddd03 100644 --- a/src/Kupo/Data/Cardano/Script.hs +++ b/src/Kupo/Data/Cardano/Script.hs @@ -27,6 +27,7 @@ import qualified Cardano.Ledger.Alonzo.Scripts as Ledger.Alonzo import qualified Cardano.Ledger.Alonzo.TxAuxData as Ledger.Alonzo import qualified Cardano.Ledger.Binary.Plain as Ledger import qualified Cardano.Ledger.Core as Ledger.Core +import qualified Cardano.Ledger.Dijkstra.Scripts as Ledger.Dijkstra import qualified Cardano.Ledger.Plutus.Language as Ledger import qualified Codec.CBOR.Decoding as Cbor @@ -37,7 +38,7 @@ import qualified Data.ByteString as BS import qualified Data.Map as Map type Script = - Ledger.Alonzo.Script ConwayEra + Ledger.Alonzo.Script DijkstraEra scriptFromAllegraAuxiliaryData :: forall era. @@ -75,14 +76,14 @@ fromAllegraScript :: Ledger.Allegra.Timelock AllegraEra -> Script fromAllegraScript = - Ledger.Alonzo.NativeScript . Ledger.Allegra.translateTimelock + Ledger.Alonzo.NativeScript . Ledger.Dijkstra.upgradeTimelock . Ledger.Allegra.translateTimelock {-# INLINABLE fromAllegraScript #-} fromMaryScript :: Ledger.Allegra.Timelock MaryEra -> Script fromMaryScript = - Ledger.Alonzo.NativeScript . Ledger.Allegra.translateTimelock + Ledger.Alonzo.NativeScript . Ledger.Dijkstra.upgradeTimelock . Ledger.Allegra.translateTimelock {-# INLINABLE fromMaryScript #-} fromAlonzoScript @@ -96,14 +97,14 @@ fromBabbageScript :: Ledger.Alonzo.Script BabbageEra -> Script fromBabbageScript = - Ledger.Core.upgradeScript + Ledger.Core.upgradeScript . Ledger.Core.upgradeScript {-# INLINABLE fromBabbageScript #-} fromConwayScript :: Ledger.Alonzo.Script ConwayEra -> Script fromConwayScript = - identity + Ledger.Core.upgradeScript {-# INLINABLE fromConwayScript #-} scriptToJson @@ -154,7 +155,7 @@ scriptFromBytes (toLazy -> bytes) = (script, tag) <- left (DecoderErrorDeserialiseFailure "Script") $ Cbor.deserialiseFromBytes Cbor.decodeWord8 bytes case tag of - 0 -> Ledger.Alonzo.NativeScript <$> decodeCborAnn @BabbageEra "Timelock" decCBOR script + 0 -> Ledger.Alonzo.NativeScript <$> decodeCborAnn @DijkstraEra "DijkstraNativeScript" decCBOR script 1 -> plutusScript Ledger.PlutusV1 script 2 -> plutusScript Ledger.PlutusV2 script 3 -> plutusScript Ledger.PlutusV3 script @@ -168,7 +169,7 @@ scriptFromBytes (toLazy -> bytes) = script = maybeToRight (Ledger.DecoderErrorCustom "Incompatible language and era" $ show (lang, uplc)) - (Ledger.Alonzo.mkBinaryPlutusScript @Maybe @ConwayEra lang uplc) + (Ledger.Alonzo.mkBinaryPlutusScript @Maybe @DijkstraEra lang uplc) in Ledger.Alonzo.PlutusScript <$> script @@ -183,7 +184,7 @@ hashScript :: Script -> ScriptHash hashScript = - Ledger.Core.hashScript @ConwayEra + Ledger.Core.hashScript @DijkstraEra {-# INLINABLE hashScript #-} newtype ComparableScript = ComparableScript { unComparableScript :: Script } diff --git a/src/Kupo/Data/Cardano/Transaction.hs b/src/Kupo/Data/Cardano/Transaction.hs index 9b91efad..87fc7594 100644 --- a/src/Kupo/Data/Cardano/Transaction.hs +++ b/src/Kupo/Data/Cardano/Transaction.hs @@ -34,6 +34,8 @@ data Transaction !(Ledger.Tx Ledger.TopTx BabbageEra) | TransactionConway !(Ledger.Tx Ledger.TopTx ConwayEra) + | TransactionDijkstra + !(Ledger.Tx Ledger.TopTx DijkstraEra) instance HasTransactionId Transaction where getTransactionId = \case @@ -51,3 +53,5 @@ instance HasTransactionId Transaction where Ledger.txIdTx @BabbageEra tx TransactionConway tx -> Ledger.txIdTx @ConwayEra tx + TransactionDijkstra tx -> + Ledger.txIdTx @DijkstraEra tx diff --git a/src/Kupo/Data/Database.hs b/src/Kupo/Data/Database.hs index 7a326ce3..53d3608d 100644 --- a/src/Kupo/Data/Database.hs +++ b/src/Kupo/Data/Database.hs @@ -119,7 +119,7 @@ pointFromRow -> App.Point pointFromRow row = App.BlockPoint (App.SlotNo (checkpointSlotNo row)) - (fromShortRawHash (Proxy @App.Block) $ toShort $ checkpointHeaderHash row) + (unsafeFromShortRawHash (Proxy @App.Block) $ toShort $ checkpointHeaderHash row) {-# INLINABLE pointFromRow #-} pointToRow diff --git a/src/Kupo/Data/Hydra.hs b/src/Kupo/Data/Hydra.hs index b9b9cc31..dfa54efa 100644 --- a/src/Kupo/Data/Hydra.hs +++ b/src/Kupo/Data/Hydra.hs @@ -12,9 +12,6 @@ import Cardano.Crypto.Hash import Cardano.Ledger.Alonzo.Scripts ( AsIx (..) ) -import Cardano.Ledger.Conway.Scripts - ( ConwayPlutusPurpose (..) - ) import Cardano.Ledger.Alonzo.TxWits ( unRedeemers , unTxDats @@ -28,6 +25,9 @@ import Cardano.Ledger.Api , scriptTxWitsL , witsTxL ) +import Cardano.Ledger.Conway.Scripts + ( ConwayPlutusPurpose (..) + ) import Cardano.Ledger.Core ( TopTx ) @@ -53,6 +53,7 @@ import Kupo.Data.Cardano , Value , binaryDataFromBytes , fromConwayData + , fromConwayOutput , fromConwayScript , getOutputIndex , getTransactionId @@ -202,7 +203,7 @@ decodePartialTransaction = Json.withObject "PartialTransaction" $ \o -> do let body' = tx ^. bodyTxL let id = Ledger.txIdTxBody body' let wits' = tx ^. witsTxL - let outputs' = toList (body' ^. outputsTxBodyL) + let outputs' = toList (fromConwayOutput <$> body' ^. outputsTxBodyL) pure PartialTransaction { id diff --git a/src/Kupo/Prelude.hs b/src/Kupo/Prelude.hs index 2cf21655..36e956c0 100644 --- a/src/Kupo/Prelude.hs +++ b/src/Kupo/Prelude.hs @@ -75,6 +75,7 @@ module Kupo.Prelude , AlonzoEra , BabbageEra , ConwayEra + , DijkstraEra , MostRecentEra -- * System @@ -111,6 +112,9 @@ import Cardano.Ledger.Core , Era , eraProtVerLow ) +import Cardano.Ledger.Dijkstra + ( DijkstraEra + ) import Cardano.Ledger.Mary ( MaryEra ) diff --git a/test/Test/Kupo/App/HttpSpec.hs b/test/Test/Kupo/App/HttpSpec.hs index e68b4b10..06f29683 100644 --- a/test/Test/Kupo/App/HttpSpec.hs +++ b/test/Test/Kupo/App/HttpSpec.hs @@ -8,10 +8,6 @@ module Test.Kupo.App.HttpSpec ( spec ) where -import Kupo.Prelude hiding - ( get - , put - ) import Data.Aeson ( (.!=) , (.:) @@ -78,6 +74,10 @@ import Kupo.Data.Pattern ( Pattern , patternToText ) +import Kupo.Prelude hiding + ( get + , put + ) import Network.HTTP.Media.MediaType ( MediaType , (//) diff --git a/test/Test/Kupo/Data/Generators.hs b/test/Test/Kupo/Data/Generators.hs index 06db85f9..267d8b51 100644 --- a/test/Test/Kupo/Data/Generators.hs +++ b/test/Test/Kupo/Data/Generators.hs @@ -8,6 +8,10 @@ module Test.Kupo.Data.Generators where import Kupo.Prelude +import Kupo.Data.Cardano.Metadata + ( byteStringToByteArray + ) + import Data.Bits ( shiftL ) @@ -352,7 +356,7 @@ genMetadata = do genMetadatum = sized $ \case 0 -> oneof [ I <$> arbitrary - , B <$> (choose (0, 16) >>= genBytes) + , B . byteStringToByteArray <$> (choose (0, 16) >>= genBytes) , S . T.pack <$> (chooseVector (0, 24) (elements ['a'..'z'])) ] ((truncate @Double . log . fromIntegral) -> n) -> oneof diff --git a/test/Test/KupoSpec.hs b/test/Test/KupoSpec.hs index 901f32d4..517e2c72 100644 --- a/test/Test/KupoSpec.hs +++ b/test/Test/KupoSpec.hs @@ -194,13 +194,13 @@ import Kupo.Data.Health ( ConnectionStatus (..) , Health (..) ) +import System.Environment + ( getEnvironment + ) import System.IO ( hClose , hGetLine ) -import System.Environment - ( getEnvironment - ) import qualified Data.Aeson as Json import qualified Data.Text as T