Merge pull request #523 from input-output-hk/SCP-5083

SCP-5083 Fixed inclusion of stake address in marlowe address.
input-output-hk · Mar 17, 2023 · 130b8ca · 130b8ca
2 parents 8f97cd4 + fc08673
commit 130b8ca
Showing 1 changed file with 30 additions and 18 deletions.
diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Run.hs b/marlowe-cli/src/Language/Marlowe/CLI/Run.hs
@@ -235,18 +235,19 @@ initializeTransaction connection marloweParams slotConfig protocolVersion costMo
                                             $ findMarloweScriptsRefs connection publishingStrategy' (PrintStats printStats)
     contract <- decodeFileStrict contractFile
     state    <- decodeFileStrict stateFile
-    marloweTransaction <- initializeTransactionImpl
-      marloweParams
-      slotConfig
-      protocolVersion
-      costModelParams
-      network
-      stake
-      contract
-      state
-      refs
-      merkleize
-      printStats
+    marloweTransaction <- withShelleyBasedEra era $
+      initializeTransactionImpl
+        marloweParams
+        slotConfig
+        protocolVersion
+        costModelParams
+        network
+        stake
+        contract
+        state
+        refs
+        merkleize
+        printStats
     maybeWriteJson outputFile $
       SomeMarloweTransaction
       (plutusScriptVersion :: PlutusScriptVersion MarlowePlutusVersion)
@@ -258,6 +259,7 @@ initializeTransaction connection marloweParams slotConfig protocolVersion costMo
 initializeTransactionImpl :: forall m era
                            . MonadError CliError m
                           => MonadIO m
+                          => C.IsShelleyBasedEra era
                           => MonadReader (CliEnv era) m
                           => MarloweParams                      -- ^ The Marlowe contract parameters.
                           -> SlotConfig                         -- ^ The POSIXTime-to-slot configuration.
@@ -282,12 +284,22 @@ initializeTransactionImpl marloweParams mtSlotConfig protocolVersion costModelPa
                                          mv <- liftCli $ marloweValidatorInfo era protocolVersion costModelParams network stake
                                          rv <- liftCli $ roleValidatorInfo era protocolVersion costModelParams network stake
                                          pure (mv, rv)
-        Just MarloweScriptsRefs{..} -> pure
-                                         (
-                                           snd mrMarloweValidator
-                                         , snd mrRolePayoutValidator
-                                         )
-
+        Just MarloweScriptsRefs{..} -> do
+                                         let
+                                           vi = snd mrMarloweValidator
+                                         vi' <-
+                                           case toShelleyAddress $ viAddress vi of
+                                             Nothing -> throwError "Expecting shelley address in reference validator info"
+                                             Just (CS.ShelleyAddress n p _) ->
+                                               pure
+                                                 $ vi
+                                                   {
+                                                     viAddress =
+                                                       C.shelleyAddressInEra
+                                                         $ CS.ShelleyAddress n p
+                                                         $ toShelleyStakeReference stake
+                                                   }
+                                         pure (vi' , snd mrRolePayoutValidator)
     let
       ValidatorInfo{..} = mtValidator
       mtContinuations = mempty