From e495b4c35b38da7cbed3d9457114cb3750da4ef2 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Tue, 3 Nov 2026 17:24:35 +0100 Subject: [PATCH] Update cardano deps and support Dijkstra blocks --- .github/workflows/continuous-integration.yaml | 2 +- CHANGELOG.md | 6 +- cabal.project | 32 ++--- flake.lock | 6 +- kupo.cabal | 2 + package.yaml | 2 + perSystem/project.nix | 2 +- src/Kupo/App.hs | 4 + src/Kupo/App/Configuration.hs | 2 +- src/Kupo/App/Http.hs | 1 + src/Kupo/Control/MonadLog.hs | 3 +- src/Kupo/Data/Cardano.hs | 125 +++++++++++++++--- src/Kupo/Data/Cardano/BinaryData.hs | 12 +- src/Kupo/Data/Cardano/Datum.hs | 23 ++-- src/Kupo/Data/Cardano/HeaderHash.hs | 2 +- src/Kupo/Data/Cardano/Metadata.hs | 38 ++++-- src/Kupo/Data/Cardano/NativeScript.hs | 3 +- src/Kupo/Data/Cardano/Output.hs | 19 ++- src/Kupo/Data/Cardano/Redeemers.hs | 6 + src/Kupo/Data/Cardano/Script.hs | 17 +-- src/Kupo/Data/Cardano/Transaction.hs | 4 + src/Kupo/Data/Database.hs | 2 +- src/Kupo/Data/Hydra.hs | 10 +- src/Kupo/Data/Ogmios.hs | 7 +- src/Kupo/Data/PartialBlock.hs | 10 ++ src/Kupo/Prelude.hs | 4 + test/Test/Kupo/App/HttpSpec.hs | 10 +- test/Test/Kupo/AppSpec.hs | 6 +- test/Test/Kupo/Data/DatabaseSpec.hs | 4 +- test/Test/Kupo/Data/Generators.hs | 6 +- test/Test/Kupo/Data/HydraSpec.hs | 4 +- test/Test/Kupo/Data/OgmiosSpec.hs | 75 ++++++++++- test/Test/KupoSpec.hs | 6 +- 33 files changed, 338 insertions(+), 117 deletions(-) diff --git a/.github/workflows/continuous-integration.yaml b/.github/workflows/continuous-integration.yaml index 78c49302..9f3b122d 100644 --- a/.github/workflows/continuous-integration.yaml +++ b/.github/workflows/continuous-integration.yaml @@ -11,7 +11,7 @@ on: - master env: - CARDANO_NODE_VERSION: "11.0.1" + CARDANO_NODE_VERSION: "11.1.3" NETWORK: preprod S3_DB_PATH: s3://${{ secrets.AWS_S3_BUCKET }}/db-preprod diff --git a/CHANGELOG.md b/CHANGELOG.md index 62af2d9f..d928229e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,11 +2,13 @@ #### Added -N/A +- Kupo now indexes Dijkstra blocks when it is connected directly to cardano-node. With Ogmios, Kupo stops with an error at the first Dijkstra block, because Ogmios does not serialise Dijkstra transactions yet. + +- A Dijkstra transaction that carries sub-transactions is not indexed yet. Kupo stops with an error that names the transaction. #### Changed -- Bumped internal dependencies to cardano-node==10.5.1 +- Kupo now requires cardano-node 11.1 or later. It talks to the node over node-to-client version 23 only, so older nodes are no longer supported. - Kupo is now built with GHC 9.12. diff --git a/cabal.project b/cabal.project index f5819126..661b2b8d 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-10-23T00:00:00Z + , cardano-haskell-packages 2026-10-30T15:04:17Z packages: ./ @@ -46,16 +46,14 @@ package direct-sqlite flags: +nomutex constraints: - , any.cardano-node == 11.0.1 + , any.cardano-ledger-conway >= 1.24 - , any.cardano-ledger-conway >= 1.22.1.0 + , any.ouroboros-consensus ^>= 5.3 + , any.ouroboros-network ^>= 2.0 + , any.cardano-diffusion >= 1.3 - , any.ouroboros-consensus ^>= 3.0.1 - , any.ouroboros-network ^>= 1.1 - - , any.io-classes ^>= 1.8 , any.formatting == 7.2.0 - , any.validation < 1.2 + , any.fast-bech32 == 1.0.1 , any.text source -- Use serial block IO instead of io_uring to avoid requiring liburing @@ -64,21 +62,15 @@ constraints: , direct-sqlite == 2.3.29.1 , sqlite-simple == 0.4.19.0.1 -allow-newer: - *:formatting - , katip:Win32 - , io-sim:time - , 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: UhvUWcW5U20bAGmPF90drDS+oAy8YGRJVUQBZHNOSPM= + tag: 2f9b5d14daeccfece3a7d33f8a10e2136a91fbef subdir: - server/modules/fast-bech32 + server/modules/contra-tracers source-repository-package type: git diff --git a/flake.lock b/flake.lock index 3a782b2d..dba38f48 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": 1793387056, + "narHash": "sha256-b9iFweYcsxm97EHhbEBZUEePSoEye4PDZ4Rh0w0p1iw=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "61c9835abcfc3a6c9b6279226d4502fa877bb6a7", + "rev": "60c2f8adf87302355db3a15258eb562a4af9f22d", "type": "github" }, "original": { diff --git a/kupo.cabal b/kupo.cabal index 2b61653d..39f9adc6 100644 --- a/kupo.cabal +++ b/kupo.cabal @@ -186,6 +186,7 @@ library , bytestring , cardano-crypto-class , cardano-crypto-wrapper + , cardano-data , cardano-diffusion , cardano-ledger-allegra , cardano-ledger-alonzo @@ -195,6 +196,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/package.yaml b/package.yaml index 96e8843a..a40aa130 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/perSystem/project.nix b/perSystem/project.nix index 14640d20..74a3a5d9 100644 --- a/perSystem/project.nix +++ b/perSystem/project.nix @@ -35,7 +35,7 @@ # Mirrors source-repository-package entries in cabal.project so # haskell.nix can fetch them deterministically. sha256map = { - "https://github.com/CardanoSolutions/ogmios"."ae876badb138f42dcd6d2389734b0c15502684ed" = "sha256-xkOfOdX6Dxi7+VW78Tk3n3MoguIg39pKdxiNVfdeEwE="; + "https://github.com/IntersectMBO/ogmios"."2f9b5d14daeccfece3a7d33f8a10e2136a91fbef" = "sha256-UhvUWcW5U20bAGmPF90drDS+oAy8YGRJVUQBZHNOSPM="; "https://github.com/CardanoSolutions/sqlite-simple"."08015be2ee52a7e67159b6b0c476bd3e0a2e0b87" = "1ahpjycsfibv09kzgfbm4i55z4nz1p3rvnmfwwwraxy45n1ivl85"; "https://github.com/CardanoSolutions/direct-sqlite"."2b14a78cb73805e2e5d84354230e872a223faa39" = "1lwaariy0zjjh006ll1zbpdi9sphyqmcbbxhb0rj99nii5s91fd7"; "https://github.com/CardanoSolutions/text-ansi"."e204822d2f343b2d393170a2ec46ee935571345c" = "16ki7wsf7wivxn65acv4hxwfrzmphq4zp61lpxwzqkgrg8shi8bv"; diff --git a/src/Kupo/App.hs b/src/Kupo/App.hs index 8dbf0a95..3cbe5303 100644 --- a/src/Kupo/App.hs +++ b/src/Kupo/App.hs @@ -113,6 +113,7 @@ import Kupo.Data.Cardano , SlotNo (..) , Tip , TransactionId + , checkSubTransactions , distanceToTip , getPoint , getPointSlotNo @@ -513,11 +514,13 @@ rollForwardAll :: forall m block. ( MonadSTM m , MonadLog m + , MonadThrow m , Monad (DBTransaction m) , IsBlock block ) => RollForward m block rollForwardAll tr inputManagement notifyTip Database{..} patterns blks = do + forM_ blks (either throwIO pure . checkSubTransactions . snd) let (lastKnownTip, lastKnownBlk) = last blks let lastKnownPoint = getPoint lastKnownBlk let lastKnownSlot = getPointSlotNo lastKnownPoint @@ -581,6 +584,7 @@ rollForwardUntil :: forall m block. ( MonadSTM m , MonadLog m + , MonadThrow m , Monad (DBTransaction m) , IsBlock block ) diff --git a/src/Kupo/App/Configuration.hs b/src/Kupo/App/Configuration.hs index 915035c8..b2ba698b 100644 --- a/src/Kupo/App/Configuration.hs +++ b/src/Kupo/App/Configuration.hs @@ -95,7 +95,7 @@ import qualified Network.WebSockets.Tls as WSS -- nodeToClientVMin :: NodeToClientVersion -nodeToClientVMin = NodeToClientV_16 +nodeToClientVMin = NodeToClientV_23 hydrateChainProducer :: ChainProducer () -> IO (ChainProducer (TMVar IO NetworkParameters)) hydrateChainProducer = \case diff --git a/src/Kupo/App/Http.hs b/src/Kupo/App/Http.hs index 12875319..4ba5075b 100644 --- a/src/Kupo/App/Http.hs +++ b/src/Kupo/App/Http.hs @@ -814,6 +814,7 @@ handleGetMetadata baseHeaders slotArg queryParams Database{..} fetchBlock = ) : baseHeaders atomically $ putTMVar response $ responseStreamJson headers metadataToJson' $ \yield done -> do + either throwIO pure (checkSubTransactions blk) traverse_ yield $ foldBlock (\ix tx -> if isNothing filterBy || Just (getTransactionId tx) == filterBy then 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..0b750983 100644 --- a/src/Kupo/Data/Cardano.hs +++ b/src/Kupo/Data/Cardano.hs @@ -10,6 +10,7 @@ module Kupo.Data.Cardano ( IsBlock (..) + , UnsupportedSubTransactions (..) , module Kupo.Data.Cardano.Address , module Kupo.Data.Cardano.AssetId , module Kupo.Data.Cardano.AssetName @@ -102,6 +103,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 @@ -119,6 +122,11 @@ class HasTransactionId (BlockBody block) => IsBlock (block :: Type) where -> block -> result + -- | Fails on a block whose Dijkstra sub-transactions are not indexable. + checkSubTransactions + :: block + -> Either UnsupportedSubTransactions () + spentInputs :: BlockBody block -> Set Input @@ -147,10 +155,29 @@ class HasTransactionId (BlockBody block) => IsBlock (block :: Type) where -- Block +-- | Raised on a block carrying Dijkstra sub-transactions, which are not indexed yet. +data UnsupportedSubTransactions + = UnsupportedSubTransactions !TransactionId + -- ^ A Dijkstra transaction carries sub-transactions. + | UnverifiableSubTransactions !Point + -- ^ A Dijkstra block whose transactions Kupo cannot inspect. + deriving (Show) + +instance Exception UnsupportedSubTransactions where + displayException = \case + UnsupportedSubTransactions txId -> + "Dijkstra transaction " <> toString (transactionIdToText txId) + <> " carries sub-transactions, which Kupo does not index yet." + UnverifiableSubTransactions point -> + "Ogmios does not serialise Dijkstra transactions yet, so Kupo cannot index the block at slot " + <> toString (slotNoToText (getPointSlotNo point)) + <> ". Connect Kupo directly to cardano-node to index Dijkstra blocks." + instance IsBlock Void where type BlockBody Void = Void getPoint = absurd foldBlock _ _ = absurd + checkSubTransactions = absurd spentInputs = absurd mapMaybeOutputs _ = absurd witnessedDatums = absurd @@ -194,9 +221,23 @@ 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) result (txs ^. Ledger.txSeqBlockBodyL) + + checkSubTransactions = \case + BlockDijkstra (ShelleyBlock (Ledger.Block _ txs) _) -> + traverse_ rejectSubTransactions (txs ^. Ledger.txSeqBlockBodyL) + _ -> + Right () + where + -- Sub-transactions are not indexed yet: fail loudly instead of + -- silently dropping their inputs and outputs. + rejectSubTransactions + :: Ledger.Tx Ledger.TopTx DijkstraEra + -> Either UnsupportedSubTransactions () + rejectSubTransactions tx = + unless (OMap.null (tx ^. Ledger.bodyTxL . Ledger.subTransactionsTxBodyL)) $ + Left (UnsupportedSubTransactions (Ledger.txIdTx @DijkstraEra tx)) spentInputs :: Transaction @@ -211,22 +252,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.IsValid False -> + Ledger.Phase2Invalid -> + tx ^. Ledger.bodyTxL . Ledger.collateralInputsTxBodyL + TransactionDijkstra tx -> + case tx ^. Ledger.isPhase2ValidTxL of + Ledger.Phase2Valid -> + tx ^. Ledger.bodyTxL . Ledger.inputsTxBodyL + Ledger.Phase2Invalid -> tx ^. Ledger.bodyTxL . Ledger.collateralInputsTxBodyL where transformByron (Ledger.Byron.TxInUtxo txId ix) = @@ -276,10 +323,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 +335,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 +356,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 +447,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 +481,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 +543,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 +570,5 @@ instance IsBlock Block where Just (RedeemersBabbage (tx ^. Ledger.witsTxL . Ledger.rdmrsTxWitsL)) TransactionConway tx -> Just (RedeemersConway (tx ^. Ledger.witsTxL . Ledger.rdmrsTxWitsL)) + TransactionDijkstra tx -> + Just (RedeemersDijkstra (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..32d9e89b 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) + | RedeemersDijkstra (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 + RedeemersDijkstra (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..1554119a 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 @@ -120,6 +121,7 @@ mkHydraBlock number txs = do , PartialBlock { blockPoint = BlockPoint slotNo headerHash , blockBody = toList txs + , isDijkstraBlock = False } ) @@ -202,7 +204,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/Data/Ogmios.hs b/src/Kupo/Data/Ogmios.hs index 0b24ee28..682cf30d 100644 --- a/src/Kupo/Data/Ogmios.hs +++ b/src/Kupo/Data/Ogmios.hs @@ -199,8 +199,11 @@ decodeBlock = Json.withObject "Block" $ \o -> do slot <- o .:? "slot" >>= \case Just slot -> pure slot Nothing -> o .: "height" - txs <- o .:? "transactions" .!= [] - PartialBlock (BlockPoint (SlotNo slot) id) <$> traverse decodePartialTransaction txs + isDijkstraBlock <- (== Just ("dijkstra" :: Text)) <$> o .:? "era" + -- Ogmios serialises Dijkstra transactions as stubs, which do not decode. + txs <- if isDijkstraBlock then pure [] else o .:? "transactions" .!= [] + blockBody <- traverse decodePartialTransaction txs + pure PartialBlock { blockPoint = BlockPoint (SlotNo slot) id, blockBody, isDijkstraBlock } decodePartialTransaction :: Json.Value diff --git a/src/Kupo/Data/PartialBlock.hs b/src/Kupo/Data/PartialBlock.hs index 1601fff4..86e61d16 100644 --- a/src/Kupo/Data/PartialBlock.hs +++ b/src/Kupo/Data/PartialBlock.hs @@ -24,6 +24,7 @@ import Kupo.Data.Cardano , Script , ScriptHash , TransactionId + , UnsupportedSubTransactions (..) , emptyMetadata ) @@ -35,6 +36,11 @@ import qualified Data.Set as Set data PartialBlock = PartialBlock { blockPoint :: !Point , blockBody :: ![PartialTransaction] + -- ^ The decoded transactions, empty for a Dijkstra block. + , isDijkstraBlock :: !Bool + -- ^ Whether this is a Dijkstra block whose transactions were not decoded. + -- Ogmios sends Dijkstra transactions without their bodies, and Hydra + -- decodes Conway transactions only. } deriving (Eq, Show) -- | A partial transaction, analogous to 'PartialBlock', trimmed down to the @@ -64,6 +70,10 @@ instance IsBlock PartialBlock where foldBlock fn result = foldrWithIndex fn result . blockBody + checkSubTransactions PartialBlock{blockPoint, isDijkstraBlock} = + when isDijkstraBlock $ + Left (UnverifiableSubTransactions blockPoint) + mapMaybeOutputs fn tx = let meta = maybe emptyMetadata snd (metadata tx) in mapMaybe (\outs -> uncurry fn outs meta) (outputs tx) 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..6ddaeb48 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 , (//) @@ -540,7 +540,7 @@ newStubbedApplication defaultPatterns = do , spendRedeemers = mempty , metadata } - pure $ PartialBlock { blockPoint, blockBody } + pure $ PartialBlock { blockPoint, blockBody, isDijkstraBlock = False } ) patternsVar healthStub diff --git a/test/Test/Kupo/AppSpec.hs b/test/Test/Kupo/AppSpec.hs index 0eefdecb..5f1d5135 100644 --- a/test/Test/Kupo/AppSpec.hs +++ b/test/Test/Kupo/AppSpec.hs @@ -194,7 +194,7 @@ import Test.QuickCheck.Monadic , run ) import Test.QuickCheck.Property - ( withMaxSuccess + ( withNumTests ) import Test.StateMachine ( CommandNames @@ -249,7 +249,7 @@ spec = do maxSuccess <- maybe 30 Prelude.read <$> runIO (lookupEnv varStateMachineIterations) - prop "State-Machine" $ withMaxSuccess maxSuccess $ + prop "State-Machine" $ withNumTests maxSuccess $ forAll genInputManagement $ \inputManagement -> do forAll genServerPort $ \serverPort -> do let httpClient = newHttpClientWith manager (serverHost, serverPort) (\_ -> pure ()) @@ -739,7 +739,7 @@ genContinuingBlock utxo txs previousTip = do blockPoint <- BlockPoint (next (getPointSlotNo previousTip)) <$> genHeaderHash (txs', utxo') <- runStateT (genTransactionSublist txs) utxo blockBody <- (txs' <>) <$> evalStateT genPartialTransactions utxo' - pure PartialBlock { blockPoint, blockBody } + pure PartialBlock { blockPoint, blockBody, isDijkstraBlock = False } -- | Generate a list of transactions using and modifying a given utxo. The -- generation stops when there's no more utxos or, arbitrarily (1 chance out of diff --git a/test/Test/Kupo/Data/DatabaseSpec.hs b/test/Test/Kupo/Data/DatabaseSpec.hs index 7a67d79e..ab10d64f 100644 --- a/test/Test/Kupo/Data/DatabaseSpec.hs +++ b/test/Test/Kupo/Data/DatabaseSpec.hs @@ -176,7 +176,7 @@ import Test.QuickCheck , property , scale , shrinkList - , withMaxSuccess + , withNumTests , (.&&.) ) import Test.QuickCheck.Monadic @@ -300,7 +300,7 @@ spec = parallel $ do ] forAllShrinkShow genConflictingResults shrinkResults showResults $ \results -> - withMaxSuccess 50 $ monadicIO $ do + withNumTests 50 $ monadicIO $ do (asc, desc) <- withInMemoryDatabase 10 $ \Database{..} -> do let matchAll = MatchAny IncludingBootstrap 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/Kupo/Data/HydraSpec.hs b/test/Test/Kupo/Data/HydraSpec.hs index 005568c4..0a9e3d4c 100644 --- a/test/Test/Kupo/Data/HydraSpec.hs +++ b/test/Test/Kupo/Data/HydraSpec.hs @@ -32,7 +32,7 @@ import Test.QuickCheck ( Property , conjoin , counterexample - , withMaxSuccess + , withNumTests ) import Test.QuickCheck.Monadic ( assert @@ -54,7 +54,7 @@ spec = parallel $ do let dir = "./test/vectors/hydra/hydra-node/golden/ServerOutput" files <- runIO (listDirectory dir) <&> map (dir ) prop "can decode test vectors" $ do - withMaxSuccess 1 $ + withNumTests 1 $ conjoin $ map (prop_canDecodeFile (mapM decodeHydraMessage . getSamples)) files prop_canDecodeFile diff --git a/test/Test/Kupo/Data/OgmiosSpec.hs b/test/Test/Kupo/Data/OgmiosSpec.hs index c0b8a69e..a9edd32c 100644 --- a/test/Test/Kupo/Data/OgmiosSpec.hs +++ b/test/Test/Kupo/Data/OgmiosSpec.hs @@ -14,8 +14,14 @@ import Data.List import Kupo.App.ChainSync.Ogmios ( intersectionNotFound ) +import Kupo.Data.Cardano + ( IsBlock (..) + , UnsupportedSubTransactions (..) + ) import Kupo.Data.Ogmios - ( decodeFindIntersectionResponse + ( NextBlockResponse (..) + , PartialBlock + , decodeFindIntersectionResponse , decodeNextBlockResponse ) import System.Directory @@ -25,18 +31,22 @@ import System.FilePath ( () ) import Test.Hspec - ( Spec + ( Expectation + , Spec , SpecWith , context + , expectationFailure + , it , parallel , runIO + , shouldSatisfy ) import Test.Hspec.QuickCheck ( prop ) import Test.QuickCheck ( counterexample - , withMaxSuccess + , withNumTests ) import Test.QuickCheck.Monadic ( assert @@ -45,6 +55,8 @@ import Test.QuickCheck.Monadic , run ) +import qualified Data.Text as Text + import Data.Aeson as Json import Data.Aeson.Types as Json @@ -65,13 +77,68 @@ spec = parallel $ context "can decode relevant Ogmios' test vectors" $ do vectors <- runIO (listDirectory dir) propVector ((dir ) <$> vectors) decodeNextBlockResponse + context "checkSubTransactions" $ do + it "rejects a Dijkstra block, whose transactions Ogmios does not serialise" $ do + let stub = Json.object + [ "id" .= txId + , "spends" .= ("inputs" :: Text) + ] + withBlock (nextBlock "dijkstra" [stub]) $ \blk -> + checkSubTransactions blk `shouldSatisfy` \case + Left UnverifiableSubTransactions{} -> True + _ -> False + + it "accepts a Conway block" $ do + let tx = Json.object + [ "id" .= txId + , "spends" .= ("inputs" :: Text) + , "inputs" .= ([] :: [Json.Value]) + , "outputs" .= ([] :: [Json.Value]) + ] + withBlock (nextBlock "conway" [tx]) $ \blk -> + checkSubTransactions blk `shouldSatisfy` isRight + +withBlock :: Json.Value -> (PartialBlock -> Expectation) -> Expectation +withBlock value check = + case Json.parse decodeNextBlockResponse value of + Json.Success (RollForward _ blk) -> check blk + Json.Success _ -> expectationFailure "expected a roll forward" + Json.Error str -> expectationFailure str + +nextBlock :: Text -> [Json.Value] -> Json.Value +nextBlock era txs = Json.object + [ "result" .= Json.object + [ "direction" .= ("forward" :: Text) + , "tip" .= point + , "block" .= Json.object + [ "type" .= ("praos" :: Text) + , "era" .= era + , "id" .= blockId + , "height" .= (1 :: Int) + , "slot" .= (42 :: Int) + , "transactions" .= txs + ] + ] + ] + where + point = Json.object + [ "id" .= blockId + , "height" .= (1 :: Int) + , "slot" .= (42 :: Int) + ] + +txId :: Text +txId = Text.replicate 64 "a" + +blockId :: Text +blockId = Text.replicate 64 "b" propVector :: [FilePath] -> (Json.Value -> Json.Parser a) -> SpecWith () propVector vectors decoder = do - prop "decode test vectors" $ withMaxSuccess 1 $ monadicIO $ do + prop "decode test vectors" $ withNumTests 1 $ monadicIO $ do forM_ [0 .. (length vectors) - 1] (\i -> shouldDecode (vectors !! i)) where shouldDecode vector = do 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