From da05d0bde3e49c81efaffec05ad13fce4d97a2fd Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Wed, 20 Mar 2024 22:04:28 +0100 Subject: [PATCH] Upgrade to hydra-0.16 Hydra 0.16 drops JSON encoding of transactions in favour of a CBOR representation only. This updates the hydra submodule to provide a golden test file in the new format. Co-Authored by Daniel Firth --- CHANGELOG.md | 2 + kupo.cabal | 1 + src/Kupo/Data/Hydra.hs | 97 +++++++++++++++++++----------------------- test/vectors/hydra | 2 +- 4 files changed, 47 insertions(+), 55 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6410b84..e5f7192 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ #### Added +* Compatibility with hydra-node 0.16.0. + - A new mode `--read-only` which can be used to boot-up an HTTP server with only read access to the underlying database. This option comes as an alternative to the other options for chain producers (e.g. `--node-socket` and `--node-config`). The replica can only reply successfully to GET queries with the exception of queries under `/metadata`. The latter must go through the master server. - Automatic restart and setup indexes when `--defer-db-indexes` is provided and the tip of the chain is reached. diff --git a/kupo.cabal b/kupo.cabal index ae26852..70fd8a3 100644 --- a/kupo.cabal +++ b/kupo.cabal @@ -173,6 +173,7 @@ library , cardano-crypto-wrapper , cardano-ledger-allegra , cardano-ledger-alonzo + , cardano-ledger-api , cardano-ledger-babbage , cardano-ledger-binary , cardano-ledger-byron diff --git a/src/Kupo/Data/Hydra.hs b/src/Kupo/Data/Hydra.hs index 6278efc..54114c4 100644 --- a/src/Kupo/Data/Hydra.hs +++ b/src/Kupo/Data/Hydra.hs @@ -9,31 +9,41 @@ import Cardano.Crypto.Hash , hashToBytes , hashWith ) +import Cardano.Ledger.Allegra.Scripts (translateTimelock) +import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..)) +import Cardano.Ledger.Alonzo.TxWits (unTxDats) +import Cardano.Ledger.Api ( + outputsTxBodyL, + inputsTxBodyL, + datsTxWitsL, + scriptTxWitsL, + witsTxL, + bodyTxL + ) +import Cardano.Ledger.Binary (decodeFullAnnotator) +import Cardano.Ledger.Block (txid) +import Cardano.Ledger.Plutus.Data (translateDatum, dataToBinaryData, upgradeData) import Cardano.Ledger.SafeHash ( unsafeMakeSafeHash ) import Data.Aeson - ( (.!=) - , (.:) + ( (.:) , (.:?) ) import Kupo.Data.Cardano ( BinaryData , BlockNo (..) , Datum (..) - , DatumHash , Input , Output , OutputIndex , OutputReference , Script - , ScriptHash , SlotNo (..) , Tip , TransactionId , Value , binaryDataFromBytes - , datumHashFromBytes , getOutputIndex , getTransactionId , mkOutput @@ -42,7 +52,6 @@ import Kupo.Data.Cardano , pattern BlockPoint , pattern Tip , scriptFromBytes - , scriptHashFromText , transactionIdFromText , transactionIdToBytes , unsafeHeaderHashFromBytes @@ -57,7 +66,9 @@ import Kupo.Data.PartialBlock ( PartialBlock (..) , PartialTransaction (..) ) - +import qualified Cardano.Ledger.Api as LedgerApi +import qualified Cardano.Ledger.Babbage.TxBody as Babbage +import qualified Cardano.Ledger.Core as Ledger import qualified Codec.CBOR.Decoding as Cbor import qualified Codec.CBOR.Read as Cbor import qualified Data.Aeson.Key as Key @@ -156,15 +167,21 @@ decodeGenesisTxForUTxO id indexOutputs = do decodePartialTransaction :: Json.Value -> Json.Parser PartialTransaction decodePartialTransaction = Json.withObject "PartialTransaction" $ \o -> do - id <- o .: "id" >>= decodeTransactionId + hexText <- o .: "cborHex" + + bytes <- decodeBase16' hexText - body <- o .: "body" - inputs <- body .: "inputs" >>= traverse decodeInput - outputs <- body .:? "outputs" .!= [] >>= traverse decodeOutput + tx <- case decodeFullAnnotator (Ledger.eraProtVerLow @(BabbageEra StandardCrypto)) "foo" decCBOR (fromStrict bytes) of + Left e -> fail $ show e + Right tx -> pure tx - wits <- o.: "witnesses" - datums <- wits .:? "datums" .!= Json.Object mempty >>= decodeDatums - scripts <- wits .:? "scripts" .!= Json.Object mempty >>= decodeScripts + let body' = tx ^. bodyTxL + let inputs = toList (body' ^. inputsTxBodyL) + let outputs = map convertOutput $ toList (body' ^. outputsTxBodyL) + let wits' = tx ^. witsTxL + let scripts = Map.map convertScript (wits' ^. scriptTxWitsL) + let datums = Map.map convertData $ unTxDats (wits' ^. datsTxWitsL) + let id = txid body' -- TODO -- This is 'acceptable' for now because: @@ -185,28 +202,18 @@ decodePartialTransaction = Json.withObject "PartialTransaction" $ \o -> do , scripts , metadata } + where + convertOutput :: Babbage.BabbageTxOut (BabbageEra StandardCrypto) -> Output + convertOutput (Babbage.BabbageTxOut addr val datum maybeScript) = + (Babbage.BabbageTxOut addr val (translateDatum datum) (convertScript <$> maybeScript)) -decodeDatums :: Json.Value -> Json.Parser (Map DatumHash BinaryData) -decodeDatums = Json.withObject "Datums" $ - KeyMap.foldrWithKey - (\k v accum -> Map.insert - <$> decodeDatumHash k - <*> decodeBinaryData v - <*> accum - ) - (pure mempty) + convertData :: LedgerApi.Data (BabbageEra StandardCrypto) -> BinaryData + convertData = dataToBinaryData . upgradeData -decodeDatumHash - :: Json.Key - -> Json.Parser DatumHash -decodeDatumHash k = do - case datumHashFromBytes <$> decodeBase16 (encodeUtf8 (Key.toText k)) of - Right (Just hash) -> - pure hash - Right Nothing -> - fail "decodeDatumHash: datumHashFromBytes failed." - Left e -> - fail (toString e) + convertScript :: AlonzoScript (BabbageEra StandardCrypto) -> Script + convertScript = \case + TimelockScript timelock -> TimelockScript (translateTimelock timelock) + PlutusScript script -> PlutusScript script decodeInput :: Json.Value @@ -301,24 +308,6 @@ decodeScriptInEnvelope = Json.withObject "ScriptInEnvelope" $ \o -> do scriptFromBytes' = maybe (fail "decodeScript: malformed script") pure . scriptFromBytes -decodeScripts :: Json.Value -> Json.Parser (Map ScriptHash Script) -decodeScripts = Json.withObject "Scripts" $ - KeyMap.foldrWithKey - (\k v accum -> Map.insert - <$> decodeScriptHash k - <*> decodeScript v - <*> accum - ) - (pure mempty) - -decodeScriptHash - :: Json.Key - -> Json.Parser ScriptHash -decodeScriptHash k = - case scriptHashFromText (Key.toText k) of - Nothing -> fail "decodeScriptHash" - Just scriptHash -> pure scriptHash - decodeSnapshotConfirmed :: Json.Object -> Json.Parser Snapshot decodeSnapshotConfirmed o = do snapshot <- o .: "snapshot" @@ -333,7 +322,7 @@ decodeValue :: Json.Value -> Json.Parser Value decodeValue = Json.withObject "Value" $ \o -> do - coins <- o .: "lovelace" + coins <- o .:? "lovelace" assets <- KeyMap.foldrWithKey (\k v accum -> if k == "lovelace" then accum else do @@ -344,7 +333,7 @@ decodeValue = Json.withObject "Value" $ \o -> do ) (pure mempty) o - pure (unsafeValueFromList coins assets) + pure (unsafeValueFromList (maybe 0 (\x -> x) coins) assets) where decodeAssets :: ByteString diff --git a/test/vectors/hydra b/test/vectors/hydra index 3d825b2..89f8fb5 160000 --- a/test/vectors/hydra +++ b/test/vectors/hydra @@ -1 +1 @@ -Subproject commit 3d825b25c511b32a663ef96df297ba2f3970e399 +Subproject commit 89f8fb543729ed2c1c459102aab89e69d022e396