diff --git a/.gitignore b/.gitignore index ded8721b..b0d8aed1 100644 --- a/.gitignore +++ b/.gitignore @@ -18,3 +18,7 @@ dist-newstyle /dist *.tar.gz /cabal.project.local + +## Local dev scripts (patch-nix-deps.sh stays tracked) +/scripts/* +!/scripts/patch-nix-deps.sh diff --git a/cabal.project b/cabal.project index bab3c3d2..dd0130ae 100644 --- a/cabal.project +++ b/cabal.project @@ -10,8 +10,8 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee index-state: - , hackage.haskell.org 2025-09-11T07:59:00Z - , cardano-haskell-packages 2025-09-11T08:36:14Z + , hackage.haskell.org 2026-08-14T13:38:07Z + , cardano-haskell-packages 2026-09-16T23:53:07Z packages: ./ @@ -46,36 +46,42 @@ package direct-sqlite flags: +nomutex constraints: - , any.cardano-node == 10.5.1 + , any.cardano-node == 11.1.1 - , any.cardano-ledger-core == 1.17.0.0 - , any.cardano-ledger-shelley == 1.16.0.0 - , any.cardano-ledger-conway == 1.19.0.0 + , any.cardano-ledger-conway >= 1.23 - , any.ouroboros-consensus == 0.27.0.0 - , any.ouroboros-consensus-cardano == 0.25.1.0 - , any.ouroboros-network == 0.21.3.0 + , any.ouroboros-consensus ^>= 4.2.1 + , any.ouroboros-network ^>= 1.2 - , any.io-classes == 1.5.0.0 - , any.io-classes-mtl == 0.1.2.0 + , any.io-classes ^>= 1.8 , any.formatting == 7.2.0 , any.text source + -- Use serial block IO instead of io_uring to avoid requiring liburing + , any.blockio +serialblockio + , 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 +-- +-- contra-tracers is taken from here rather than Hackage until a release with the +-- `Monad m` fix for contra-tracer >= 0.2 is published (see 1.0.1 in its CHANGELOG). source-repository-package type: git - location: https://github.com/CardanoSolutions/ogmios - tag: ae876badb138f42dcd6d2389734b0c15502684ed - --sha256: xkOfOdX6Dxi7+VW78Tk3n3MoguIg39pKdxiNVfdeEwE= + location: https://github.com/IntersectMBO/ogmios + --sha256: sha256-1VptE6HSuT2U+NMw7HLb5X1PqqrYpsOkl4tWHk5ygG4= + tag: 42c2bacd2d9c00087b5e29c98ee96c43ee857424 subdir: server/modules/fast-bech32 + server/modules/contra-tracers source-repository-package type: git diff --git a/kupo.cabal b/kupo.cabal index 3192190a..5b707082 100644 --- a/kupo.cabal +++ b/kupo.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.12 +cabal-version: 3.0 -- This file has been generated from package.yaml by hpack version 0.38.2. -- @@ -212,15 +212,16 @@ library , lens , lens-aeson , modern-uri + , network , network-mux , optparse-applicative + , cardano-diffusion , ouroboros-consensus - , ouroboros-consensus-cardano - , ouroboros-consensus-diffusion - , ouroboros-network - , ouroboros-network-api - , ouroboros-network-framework - , ouroboros-network-protocols + , ouroboros-consensus:cardano + , ouroboros-consensus:diffusion + , ouroboros-network:api + , ouroboros-network:framework + , ouroboros-network:protocols , prometheus , relude , resource-pool @@ -395,7 +396,7 @@ test-suite unit , process , quickcheck-state-machine , relude - , si-timers + , io-classes:si-timers , sqlite-simple , stm , temporary diff --git a/package.yaml b/package.yaml index fb57ab51..307c932d 100644 --- a/package.yaml +++ b/package.yaml @@ -93,13 +93,13 @@ library: - modern-uri - network-mux - optparse-applicative + - cardano-diffusion - ouroboros-consensus - - ouroboros-consensus-cardano - - ouroboros-consensus-diffusion - - ouroboros-network - - ouroboros-network-api - - ouroboros-network-framework - - ouroboros-network-protocols + - ouroboros-consensus:cardano + - ouroboros-consensus:diffusion + - ouroboros-network:api + - ouroboros-network:framework + - ouroboros-network:protocols - prometheus - relude - resource-pool @@ -146,7 +146,7 @@ tests: - QuickCheck - quickcheck-state-machine - relude - - si-timers + - io-classes:si-timers - sqlite-simple - stm - temporary diff --git a/src/Kupo/App/Http.hs b/src/Kupo/App/Http.hs index 1b376d20..8256ca7f 100644 --- a/src/Kupo/App/Http.hs +++ b/src/Kupo/App/Http.hs @@ -50,7 +50,8 @@ import Kupo.Control.MonadSTM ( MonadSTM (..) ) import Kupo.Control.MonadThrow - ( throwIO + ( bracket + , throwIO ) import Kupo.Control.MonadTime ( DiffTime @@ -196,6 +197,7 @@ import qualified Kupo.Data.Http.QuantityEncoding as QuantityEncoding import qualified Network.HTTP.Types.Header as Http import qualified Network.HTTP.Types.Status as Http import qualified Network.HTTP.Types.URI as Http +import qualified Network.Socket as Socket import qualified Network.Wai.Handler.Warp as Warp -- @@ -219,15 +221,22 @@ httpServer -> Int -> IO () httpServer tr networkParameters withDatabase forceRollback fetchBlock patternsVar readHealth host port = - Warp.runSettings settings - $ tracerMiddleware tr - $ app - networkParameters - withDatabaseWrapped - forceRollback - fetchBlock - patternsVar - readHealth + -- We deliberately own the listening socket via `bracket` rather than letting + -- `Warp.runSettings` open it internally. When kupo is cancelled mid-test + -- (via `race_`), warp's own teardown can fail to release the port promptly, + -- leaving the next stage's `bindPortTCP` to fail with EADDRINUSE. Bracketing + -- the socket here guarantees the fd is closed synchronously on any exit + -- path, including async cancel. + bracket (openListeningSocket host port) Socket.close $ \sock -> + Warp.runSettingsSocket settings sock + $ tracerMiddleware tr + $ app + networkParameters + withDatabaseWrapped + forceRollback + fetchBlock + patternsVar + readHealth where settings = Warp.defaultSettings & Warp.setPort port @@ -262,6 +271,21 @@ httpServer tr networkParameters withDatabase forceRollback fetchBlock patternsVa logWith tr $ HttpFailedToAcquireDatabaseConnection { attempts, retryingIn } threadDelay retryingIn >> retrying (next attempts) (2 * retryingIn) io +-- | Open a TCP listening socket bound to host:port with SO_REUSEADDR set, so +-- that the port can be rebound immediately after the socket is closed. +openListeningSocket :: String -> Int -> IO Socket.Socket +openListeningSocket host port = do + let hints = Socket.defaultHints + { Socket.addrFlags = [Socket.AI_PASSIVE, Socket.AI_NUMERICSERV] + , Socket.addrSocketType = Socket.Stream + } + addr : _ <- Socket.getAddrInfo (Just hints) (Just host) (Just (show port)) + sock <- Socket.socket (Socket.addrFamily addr) Socket.Stream Socket.defaultProtocol + Socket.setSocketOption sock Socket.ReuseAddr 1 + Socket.bind sock (Socket.addrAddress addr) + Socket.listen sock 1024 + pure sock + -- -- Router -- 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/Control/MonadOuroboros.hs b/src/Kupo/Control/MonadOuroboros.hs index 7583f437..4ddd0a52 100644 --- a/src/Kupo/Control/MonadOuroboros.hs +++ b/src/Kupo/Control/MonadOuroboros.hs @@ -34,6 +34,7 @@ import Kupo.Control.MonadThrow ) import Network.Mux ( StartOnDemandOrEagerly (..) + , nullTracers ) import Ouroboros.Consensus.Byron.Ledger.Config ( CodecConfig (..) @@ -74,7 +75,7 @@ import Ouroboros.Network.Mux , OuroborosApplication (..) , RunMiniProtocol (..) ) -import Ouroboros.Network.NodeToClient +import Cardano.Network.NodeToClient ( NetworkConnectTracers (..) , NodeToClientVersion (..) , NodeToClientVersionData (..) @@ -119,7 +120,7 @@ instance MonadOuroboros IO where connectTo (mkLocalSnocket iocp) tracers versions socket >>= either throwIO return where tracers = NetworkConnectTracers - { nctMuxTracer = nullTracer + { nctMuxTracers = nullTracers , nctHandshakeTracer = nullTracer } @@ -167,7 +168,7 @@ codecs epochSlots nodeToClientV = supportedVersions = supportedNodeToClientVersions (Proxy @(BlockT IO)) cfg = - CardanoCodecConfig byron shelley allegra mary alonzo babbage conway + CardanoCodecConfig byron shelley allegra mary alonzo babbage conway dijkstra where byron = ByronCodecConfig epochSlots shelley = ShelleyCodecConfig @@ -176,3 +177,4 @@ codecs epochSlots nodeToClientV = alonzo = ShelleyCodecConfig babbage = ShelleyCodecConfig conway = ShelleyCodecConfig + dijkstra = ShelleyCodecConfig diff --git a/src/Kupo/Data/Cardano.hs b/src/Kupo/Data/Cardano.hs index 59e9ed16..3054afa6 100644 --- a/src/Kupo/Data/Cardano.hs +++ b/src/Kupo/Data/Cardano.hs @@ -99,7 +99,6 @@ import Kupo.Data.Cardano.Value import qualified Cardano.Chain.UTxO as Ledger.Byron import qualified Cardano.Ledger.Alonzo.Core as Ledger -import qualified Cardano.Ledger.Alonzo.Tx 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 @@ -184,17 +183,17 @@ instance IsBlock Block where in foldrWithIndex ignoreProtocolTxs result (extractTxs blk) BlockShelley (ShelleyBlock (Ledger.Block _ txs) _) -> - foldrWithIndex (\ix -> fn ix . TransactionShelley) result (Ledger.fromTxSeq txs) + foldrWithIndex (\ix -> fn ix . TransactionShelley) result (txs ^. Ledger.txSeqBlockBodyL) BlockAllegra (ShelleyBlock (Ledger.Block _ txs) _) -> - foldrWithIndex (\ix -> fn ix . TransactionAllegra) result (Ledger.fromTxSeq txs) + foldrWithIndex (\ix -> fn ix . TransactionAllegra) result (txs ^. Ledger.txSeqBlockBodyL) BlockMary (ShelleyBlock (Ledger.Block _ txs) _) -> - foldrWithIndex (\ix -> fn ix . TransactionMary) result (Ledger.fromTxSeq txs) + foldrWithIndex (\ix -> fn ix . TransactionMary) result (txs ^. Ledger.txSeqBlockBodyL) BlockAlonzo (ShelleyBlock (Ledger.Block _ txs) _) -> - foldrWithIndex (\ix -> fn ix . TransactionAlonzo) result (Ledger.fromTxSeq txs) + foldrWithIndex (\ix -> fn ix . TransactionAlonzo) result (txs ^. Ledger.txSeqBlockBodyL) BlockBabbage (ShelleyBlock (Ledger.Block _ txs) _) -> - foldrWithIndex (\ix -> fn ix . TransactionBabbage) result (Ledger.fromTxSeq txs) + foldrWithIndex (\ix -> fn ix . TransactionBabbage) result (txs ^. Ledger.txSeqBlockBodyL) BlockConway (ShelleyBlock (Ledger.Block _ txs) _) -> - foldrWithIndex (\ix -> fn ix . TransactionConway) result (Ledger.fromTxSeq txs) + foldrWithIndex (\ix -> fn ix . TransactionConway) result (txs ^. Ledger.txSeqBlockBodyL) spentInputs :: Transaction @@ -209,22 +208,22 @@ 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 where transformByron (Ledger.Byron.TxInUtxo txId ix) = @@ -274,10 +273,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 @@ -286,10 +285,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 @@ -307,10 +306,10 @@ instance IsBlock Block where outs = body ^. Ledger.outputsTxBodyL meta = tx ^. Ledger.auxDataTxL & strictMaybe emptyMetadata fromConwayMetadata in - case tx ^. Ledger.isValidTxL of - Ledger.IsValid True -> + case tx ^. Ledger.isPhase2ValidTxL of + Ledger.Phase2Valid -> traverseAndTransform identity txId meta 0 outs - Ledger.IsValid False -> + Ledger.Phase2Invalid -> -- From Conway formal specification: -- -- Note that the new collOuts function generates a single output 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 9abf0456..76135ece 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 (..) ) @@ -28,6 +32,7 @@ import Ouroboros.Consensus.Util import qualified Cardano.Ledger.Allegra.Scripts as Ledger.Allegra import qualified Cardano.Ledger.Alonzo.TxAuxData as Ledger.Alonzo +import qualified Cardano.Ledger.Api.Era as Ledger import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Shelley.TxAuxData as Ledger import qualified Data.Aeson as Json @@ -35,6 +40,7 @@ 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 @@ -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 @@ -176,7 +182,7 @@ fromMaryMetadata (AllegraTxAuxData labels timelocks) = fromAlonzoMetadata :: AlonzoTxAuxData AlonzoEra -> Metadata fromAlonzoMetadata = - Ledger.Alonzo.translateAlonzoTxAuxData + Ledger.upgradeTxAuxData . Ledger.upgradeTxAuxData {-# INLINABLE fromAlonzoMetadata #-} fromBabbageMetadata :: AlonzoTxAuxData BabbageEra -> Metadata @@ -188,3 +194,15 @@ fromConwayMetadata :: AlonzoTxAuxData ConwayEra -> Metadata fromConwayMetadata = identity {-# INLINABLE fromConwayMetadata #-} + +-- +-- Helpers +-- + +-- | 'Ledger.Metadatum' stores bytes as a 'ByteArray' (since cardano-ledger-core 1.21); +-- 'ShortByteString' is a newtype over it, so the conversions are free. +byteArrayToByteString :: ByteArray -> ByteString +byteArrayToByteString = fromShort . SBS.ShortByteString + +byteStringToByteArray :: ByteString -> ByteArray +byteStringToByteArray = SBS.unShortByteString . toShort diff --git a/src/Kupo/Data/Cardano/Point.hs b/src/Kupo/Data/Cardano/Point.hs index 6c1ab358..599233a7 100644 --- a/src/Kupo/Data/Cardano/Point.hs +++ b/src/Kupo/Data/Cardano/Point.hs @@ -45,7 +45,9 @@ import qualified Ouroboros.Network.Block as Ouroboros type Point = Ouroboros.Point Block -instance ToJSON Point where +-- ouroboros-network provides a general 'ToJSON (Ouroboros.Point block)' instance +-- that conflicts with this one, so we need OVERLAPPING to prefer this definition. +instance {-# OVERLAPPING #-} ToJSON Point where toJSON = error "ToJSON Point called instead of 'toEncoding'." toEncoding = pointToJson diff --git a/src/Kupo/Data/Cardano/Script.hs b/src/Kupo/Data/Cardano/Script.hs index 6e18f464..b9bd4c50 100644 --- a/src/Kupo/Data/Cardano/Script.hs +++ b/src/Kupo/Data/Cardano/Script.hs @@ -42,9 +42,9 @@ type Script = scriptFromAllegraAuxiliaryData :: forall era. ( Ledger.Core.Era era - , Ledger.Core.Script era ~ Ledger.Allegra.Timelock era + , Ledger.Core.NativeScript era ~ Ledger.Allegra.Timelock era ) - => (Ledger.Core.Script era -> Script) + => (Ledger.Allegra.Timelock era -> Script) -> Ledger.Allegra.AllegraTxAuxData era -> Map ScriptHash Script -> Map ScriptHash Script @@ -66,7 +66,7 @@ scriptFromAlonzoAuxiliaryData -> Map ScriptHash Script scriptFromAlonzoAuxiliaryData liftScript (Ledger.Alonzo.AlonzoTxAuxData _ scripts _) m0 = foldr - (\((liftScript . Ledger.Alonzo.TimelockScript) -> s) -> Map.insert (hashScript s) s) + (\((liftScript . Ledger.Alonzo.NativeScript) -> s) -> Map.insert (hashScript s) s) m0 scripts {-# INLINABLE scriptFromAlonzoAuxiliaryData #-} @@ -75,14 +75,14 @@ fromAllegraScript :: Ledger.Allegra.Timelock AllegraEra -> Script fromAllegraScript = - Ledger.Alonzo.TimelockScript . Ledger.Allegra.translateTimelock + Ledger.Alonzo.NativeScript . Ledger.Allegra.translateTimelock {-# INLINABLE fromAllegraScript #-} fromMaryScript :: Ledger.Allegra.Timelock MaryEra -> Script fromMaryScript = - Ledger.Alonzo.TimelockScript . Ledger.Allegra.translateTimelock + Ledger.Alonzo.NativeScript . Ledger.Allegra.translateTimelock {-# INLINABLE fromMaryScript #-} fromAlonzoScript @@ -112,7 +112,7 @@ scriptToJson scriptToJson script = encodeObject [ ("script", encodeBytes (Ledger.Core.originalBytes script)) , ("language", case script of - Ledger.Alonzo.TimelockScript _ -> + Ledger.Alonzo.NativeScript _ -> Json.text "native" Ledger.Alonzo.PlutusScript ps -> case Ledger.Alonzo.plutusScriptLanguage ps of @@ -128,7 +128,7 @@ scriptToBytes scriptToBytes = let withTag n s = BS.singleton n <> Ledger.Core.originalBytes s in \case - Ledger.Alonzo.TimelockScript script -> + Ledger.Alonzo.NativeScript script -> withTag 0 script Ledger.Alonzo.PlutusScript script -> case Ledger.Alonzo.plutusScriptLanguage script of @@ -152,11 +152,11 @@ scriptFromBytes (toLazy -> bytes) = (script, tag) <- left (DecoderErrorDeserialiseFailure "Script") $ Cbor.deserialiseFromBytes Cbor.decodeWord8 bytes case tag of - 0 -> Ledger.Alonzo.TimelockScript <$> decodeCborAnn @BabbageEra "Timelock" decCBOR script + 0 -> Ledger.Alonzo.NativeScript <$> decodeCborAnn @BabbageEra "Timelock" decCBOR script 1 -> plutusScript Ledger.PlutusV1 script 2 -> plutusScript Ledger.PlutusV2 script 3 -> plutusScript Ledger.PlutusV3 script - t -> Left (DecoderErrorUnknownTag "Script" t) + t -> Left (DecoderErrorUnknownTag "Script" (fromIntegral @Word8 @Word t)) where plutusScript lang s = let @@ -165,7 +165,7 @@ scriptFromBytes (toLazy -> bytes) = script = maybeToRight (Ledger.DecoderErrorCustom "Incompatible language and era" $ show (lang, uplc)) - (Ledger.Alonzo.mkBinaryPlutusScript @ConwayEra lang uplc) + (Ledger.Alonzo.mkBinaryPlutusScript @Maybe @ConwayEra lang uplc) in Ledger.Alonzo.PlutusScript <$> script @@ -173,7 +173,7 @@ fromNativeScript :: NativeScript -> Script fromNativeScript = - Ledger.Alonzo.TimelockScript + Ledger.Alonzo.NativeScript {-# INLINABLE fromNativeScript #-} hashScript diff --git a/src/Kupo/Data/Cardano/Transaction.hs b/src/Kupo/Data/Cardano/Transaction.hs index 134a3f4e..9b91efad 100644 --- a/src/Kupo/Data/Cardano/Transaction.hs +++ b/src/Kupo/Data/Cardano/Transaction.hs @@ -8,49 +8,46 @@ import Kupo.Data.Cardano.TransactionId ) import qualified Cardano.Chain.UTxO as Ledger.Byron -import qualified Cardano.Ledger.Alonzo.Tx as Ledger.Alonzo import qualified Cardano.Ledger.Core as Ledger -import qualified Cardano.Ledger.Shelley.Tx as Ledger.Shelley -- Transaction +-- +-- TODO vanrossem: cardano-ledger >= 1.20 introduced @TxLevel@ as an extra +-- parameter on @Tx@. We pin to @Ledger.TopTx@ here to preserve the +-- chain-level transaction semantics; if kupo needs to handle sub-transactions +-- (Conway+ governance / inline plutus, etc.) this will need revisiting. data Transaction = TransactionByron !Ledger.Byron.Tx !Ledger.Byron.TxId | TransactionShelley - !(Ledger.Shelley.ShelleyTx ShelleyEra) + !(Ledger.Tx Ledger.TopTx ShelleyEra) | TransactionAllegra - !(Ledger.Shelley.ShelleyTx AllegraEra) + !(Ledger.Tx Ledger.TopTx AllegraEra) | TransactionMary - !(Ledger.Shelley.ShelleyTx MaryEra) + !(Ledger.Tx Ledger.TopTx MaryEra) | TransactionAlonzo - !(Ledger.Alonzo.AlonzoTx AlonzoEra) + !(Ledger.Tx Ledger.TopTx AlonzoEra) | TransactionBabbage - !(Ledger.Alonzo.AlonzoTx BabbageEra) + !(Ledger.Tx Ledger.TopTx BabbageEra) | TransactionConway - !(Ledger.Alonzo.AlonzoTx ConwayEra) + !(Ledger.Tx Ledger.TopTx ConwayEra) instance HasTransactionId Transaction where getTransactionId = \case TransactionByron _ i -> transactionIdFromByron i TransactionShelley tx -> - let body = Ledger.Shelley.body tx - in Ledger.txIdTxBody @ShelleyEra body + Ledger.txIdTx @ShelleyEra tx TransactionAllegra tx -> - let body = Ledger.Shelley.body tx - in Ledger.txIdTxBody @AllegraEra body + Ledger.txIdTx @AllegraEra tx TransactionMary tx -> - let body = Ledger.Shelley.body tx - in Ledger.txIdTxBody @MaryEra body + Ledger.txIdTx @MaryEra tx TransactionAlonzo tx -> - let body = Ledger.Alonzo.body tx - in Ledger.txIdTxBody @AlonzoEra body + Ledger.txIdTx @AlonzoEra tx TransactionBabbage tx -> - let body = Ledger.Alonzo.body tx - in Ledger.txIdTxBody @BabbageEra body + Ledger.txIdTx @BabbageEra tx TransactionConway tx -> - let body = Ledger.Alonzo.body tx - in Ledger.txIdTxBody @ConwayEra body + Ledger.txIdTx @ConwayEra 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 01f0401b..b9b9cc31 100644 --- a/src/Kupo/Data/Hydra.hs +++ b/src/Kupo/Data/Hydra.hs @@ -10,8 +10,10 @@ import Cardano.Crypto.Hash , hashWith ) import Cardano.Ledger.Alonzo.Scripts - ( AlonzoPlutusPurpose (..) - , AsIx (..) + ( AsIx (..) + ) +import Cardano.Ledger.Conway.Scripts + ( ConwayPlutusPurpose (..) ) import Cardano.Ledger.Alonzo.TxWits ( unRedeemers @@ -26,6 +28,9 @@ import Cardano.Ledger.Api , scriptTxWitsL , witsTxL ) +import Cardano.Ledger.Core + ( TopTx + ) import Cardano.Ledger.Hashes ( unsafeMakeSafeHash ) @@ -47,9 +52,8 @@ import Kupo.Data.Cardano , TransactionId , Value , binaryDataFromBytes - , fromBabbageData - , fromBabbageOutput - , fromBabbageScript + , fromConwayData + , fromConwayScript , getOutputIndex , getTransactionId , mkOutput @@ -181,7 +185,7 @@ decodePartialTransaction = Json.withObject "PartialTransaction" $ \o -> do bytes <- decodeBase16' hexText - tx <- case decodeCborAnn @ConwayEra "PartialTransaction" decCBOR (fromStrict bytes) of + tx :: Ledger.Tx TopTx ConwayEra <- case decodeCborAnn @ConwayEra "PartialTransaction" decCBOR (fromStrict bytes) of Left e -> fail $ show e Right tx -> pure tx @@ -198,23 +202,23 @@ decodePartialTransaction = Json.withObject "PartialTransaction" $ \o -> do let body' = tx ^. bodyTxL let id = Ledger.txIdTxBody body' let wits' = tx ^. witsTxL - let outputs' = map fromBabbageOutput $ toList (body' ^. outputsTxBodyL) + let outputs' = toList (body' ^. outputsTxBodyL) pure PartialTransaction { id , inputs = toList (body' ^. inputsTxBodyL) , outputs = withReferences 0 id outputs' - , datums = Map.map fromBabbageData $ unTxDats (wits' ^. datsTxWitsL) + , datums = Map.map fromConwayData $ unTxDats (wits' ^. datsTxWitsL) , spendRedeemers = Map.foldrWithKey (\purpose (redeemer, _) -> case purpose of - AlonzoSpending (AsIx ix) -> Map.insert (fromIntegral ix) (fromBabbageData redeemer) + ConwaySpending (AsIx ix) -> Map.insert (fromIntegral ix) (fromConwayData redeemer) _ -> identity ) mempty (unRedeemers $ wits' ^. rdmrsTxWitsL) - , scripts = Map.map fromBabbageScript (wits' ^. scriptTxWitsL) + , scripts = Map.map fromConwayScript (wits' ^. scriptTxWitsL) , metadata = Nothing } diff --git a/test/Test/Kupo/App/HttpSpec.hs b/test/Test/Kupo/App/HttpSpec.hs index e68b4b10..06817369 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 , (//) @@ -94,8 +94,10 @@ import Network.Wai ) import Test.Hspec ( Spec + , expectationFailure , parallel , runIO + , shouldBe , shouldContain , shouldSatisfy , specify @@ -139,6 +141,8 @@ import Test.QuickCheck.Monadic ) import qualified Data.Aeson 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 as BS import qualified Data.Map as Map @@ -206,6 +210,44 @@ spec = do res & Wai.assertStatus (Http.statusCode Http.status200) res & assertJson True schema + -- Insurance against ToJSON Point overlap regression. + -- + -- ouroboros-network ships a generic 'ToJSON (Ouroboros.Point block)' + -- instance that conflicts with Kupo.Data.Cardano.Point's OVERLAPPING + -- instance. If the upstream instance ever wins (e.g. a polymorphic + -- helper is introduced, generic deriving is added to a record carrying + -- a Point, or upstream renames their instance head), this test fails + -- loudly instead of silently changing the public wire format. + specify "/checkpoints encodes points as {slot_no, header_hash}" $ do + stub <- newStubbedApplication [] + Wai.withSession stub $ do + res <- Wai.request $ Wai.setPath Wai.defaultRequest "/checkpoints" + res & Wai.assertStatus (Http.statusCode Http.status200) + case Json.eitherDecode (Wai.simpleBody res) of + Left e -> + liftIO . expectationFailure $ + "GET /checkpoints did not return valid JSON: " <> e + Right (Json.Array xs) -> liftIO $ do + toList xs `shouldSatisfy` not . null + forM_ xs $ \v -> case v of + Json.Object o -> do + sort (Json.Key.toText <$> Json.KeyMap.keys o) + `shouldBe` ["header_hash", "slot_no"] + case Json.KeyMap.lookup "slot_no" o of + Just (Json.Number _) -> pure () + other -> expectationFailure $ + "slot_no must be a number, got: " <> show other + case Json.KeyMap.lookup "header_hash" o of + Just (Json.String _) -> pure () + other -> expectationFailure $ + "header_hash must be a string, got: " <> show other + other -> + expectationFailure $ + "/checkpoints element is not an object: " <> show other + Right other -> + liftIO . expectationFailure $ + "GET /checkpoints did not return a JSON array, got: " <> show other + session specification get "/matches" $ \assertJson endpoint -> do let schema = findSchema specification endpoint Http.status200 res <- Wai.request $ Wai.setPath Wai.defaultRequest "/matches" diff --git a/test/Test/Kupo/AppSpec.hs b/test/Test/Kupo/AppSpec.hs index 4e0bd353..45a5e756 100644 --- a/test/Test/Kupo/AppSpec.hs +++ b/test/Test/Kupo/AppSpec.hs @@ -143,7 +143,8 @@ import Kupo.Data.Pattern , Result (..) ) import Network.HTTP.Client - ( defaultManagerSettings + ( ManagerSettings (..) + , defaultManagerSettings , newManager ) import Network.WebSockets @@ -235,7 +236,14 @@ instance Exception UnusedFetchTipClient spec :: Spec spec = do - manager <- runIO (newManager defaultManagerSettings) + -- managerIdleConnectionCount = 0 disables the per-(host,port) idle pool. + -- Without it, QuickCheck shrinking can re-use the same random server port + -- across multiple iterations, and a stale pooled connection from the + -- previous kupo (still being served by its leftover warp worker) can + -- satisfy waitForServer's /health poll for the new kupo — then the next + -- call fails with Connection refused. See E2E_RESTART_INVESTIGATION.md. + manager <- runIO $ newManager defaultManagerSettings + { managerIdleConnectionCount = 0 } chan <- runIO newTChanIO 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 fa8ff16e..37946908 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 @@ -670,7 +670,14 @@ skippableContext prefix skippableSpec = do let cardanoNode = prefix <> " (cardano-node)" runIO ((,) <$> lookupEnv varCardanoNodeSocket <*> lookupEnv varCardanoNodeConfig) >>= \case (Just nodeSocket, Just nodeConfig) -> do + -- managerIdleConnectionCount = 0 disables the per-(host,port) idle + -- pool. Without this, when a multi-stage test (e.g. start → restart(s)) + -- restarts kupo on the same port, the test client may reuse a pooled + -- socket from the previous stage that's still being served by a + -- leftover warp worker — satisfying waitForServer with a stale + -- keep-alive, then failing the next request with Connection refused. manager <- runIO $ newManager defaultManagerSettings + { managerIdleConnectionCount = 0 } let defaultCfg = Configuration { chainProducer = CardanoNode { nodeSocket, nodeConfig, networkParameters = () } , databaseLocation = InMemory Nothing @@ -692,7 +699,10 @@ skippableContext prefix skippableSpec = do runIO ((,) <$> lookupEnv varOgmiosHost <*> lookupEnv varOgmiosPort) >>= \case (Just ogmiosHost, Just (Prelude.read -> ogmiosPort)) -> do manager <- runIO $ newManager $ - defaultManagerSettings { managerResponseTimeout = responseTimeoutNone } + defaultManagerSettings + { managerResponseTimeout = responseTimeoutNone + , managerIdleConnectionCount = 0 + } let defaultCfg = Configuration { chainProducer = Ogmios { ogmiosHost, ogmiosPort, networkParameters = () } , databaseLocation = InMemory Nothing @@ -714,7 +724,10 @@ skippableContext prefix skippableSpec = do runIO ((,) <$> lookupEnv varHydraHost <*> lookupEnv varHydraPort) >>= \case (Just hydraHost, Just (Prelude.read -> hydraPort)) -> do manager <- runIO $ newManager $ - defaultManagerSettings { managerResponseTimeout = responseTimeoutNone } + defaultManagerSettings + { managerResponseTimeout = responseTimeoutNone + , managerIdleConnectionCount = 0 + } let defaultCfg = Configuration { chainProducer = Hydra {hydraHost, hydraPort} , databaseLocation = InMemory Nothing