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 <[email protected]>

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.

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