more wip

IntersectMBO · Nov 8, 2024 · 1450d80 · 1450d80
1 parent c461679
commit 1450d80
Show file tree

Hide file tree

Showing 4 changed files with 112 additions and 63 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs
@@ -1516,7 +1516,7 @@ pPlutusStakeReferenceScriptWitnessFilesVotingProposing prefix autoBalanceExecUni
             AutoBalance -> pure (ExecutionUnits 0 0)
             ManualBalance -> pExecutionUnits $ prefix ++ "reference-tx-in"
         )
-    <*> pure Nothing
+    <*> pure NoPolicyIdSource
 
 pPlutusStakeReferenceScriptWitnessFiles
   :: String
@@ -1533,7 +1533,7 @@ pPlutusStakeReferenceScriptWitnessFiles prefix autoBalanceExecUnits =
             AutoBalance -> pure (ExecutionUnits 0 0)
             ManualBalance -> pExecutionUnits $ prefix ++ "reference-tx-in"
         )
-    <*> pure Nothing
+    <*> pure NoPolicyIdSource
 
 pPlutusScriptLanguage :: String -> Parser AnyScriptLanguage
 pPlutusScriptLanguage prefix = plutusP prefix PlutusScriptV2 "v2" <|> plutusP prefix PlutusScriptV3 "v3"
@@ -1922,7 +1922,7 @@ pTxIn sbe balance =
       -> ScriptWitnessFiles WitCtxTxIn
     createSimpleReferenceScriptWitnessFiles refTxIn =
       let simpleLang = AnyScriptLanguage SimpleScriptLanguage
-       in SimpleReferenceScriptWitnessFiles refTxIn simpleLang Nothing
+       in SimpleReferenceScriptWitnessFiles refTxIn simpleLang NoPolicyIdSource
 
   pPlutusReferenceScriptWitness
     :: ShelleyBasedEra era -> BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxTxIn)
@@ -1960,7 +1960,7 @@ pTxIn sbe balance =
       -> ExecutionUnits
       -> ScriptWitnessFiles WitCtxTxIn
     createPlutusReferenceScriptWitnessFiles refIn sLang sDatum sRedeemer execUnits =
-      PlutusReferenceScriptWitnessFiles refIn sLang sDatum sRedeemer execUnits Nothing
+      PlutusReferenceScriptWitnessFiles refIn sLang sDatum sRedeemer execUnits NoPolicyIdSource
 
   pEmbeddedPlutusScriptWitness :: Parser (ScriptWitnessFiles WitCtxTxIn)
   pEmbeddedPlutusScriptWitness =
@@ -2170,7 +2170,7 @@ pMintMultiAsset sbe balanceExecUnits =
       -> ScriptWitnessFiles WitCtxMint
     createSimpleMintingReferenceScriptWitnessFiles refTxIn pid =
       let simpleLang = AnyScriptLanguage SimpleScriptLanguage
-       in SimpleReferenceScriptWitnessFiles refTxIn simpleLang (Just pid)
+       in SimpleReferenceScriptWitnessFiles refTxIn simpleLang (ConcretePolicyId pid)
 
   pPlutusMintReferenceScriptWitnessFiles
     :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxMint)
@@ -2184,7 +2184,7 @@ pMintMultiAsset sbe balanceExecUnits =
               AutoBalance -> pure (ExecutionUnits 0 0)
               ManualBalance -> pExecutionUnits "mint-reference-tx-in"
           )
-      <*> (Just <$> pPolicyId)
+      <*> (ConcretePolicyId <$> pPolicyId)
 
   helpText =
     mconcat

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
@@ -73,6 +74,7 @@ import qualified Data.List as List
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList)
+import           Data.Proxy
 import           Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Text as Text
@@ -169,7 +171,7 @@ runTransactionBuildCmd
     txMetadata <-
       firstExceptT TxCmdMetadataError . newExceptT $
         readTxMetadata eon metadataSchema metadataFiles
-    valuesWithScriptWits <- readValueScriptWitnesses eon $ fromMaybe mempty mValue
+    valuesWithScriptWits <- readMintScriptWitnesses eon (const undefined) $ fromMaybe mempty mValue
     scripts <-
       firstExceptT TxCmdScriptFileError $
         mapM (readFileScriptInAnyLang . unFile) scriptFiles
@@ -205,7 +207,7 @@ runTransactionBuildCmd
     let allReferenceInputs =
           getAllReferenceInputs
             inputsAndMaybeScriptWits
-            (snd <$> snd valuesWithScriptWits)
+            (snd valuesWithScriptWits)
             certsAndMaybeScriptWits
             withdrawalsAndMaybeScriptWits
             votingProceduresAndMaybeScriptWits
@@ -360,7 +362,7 @@ runTransactionBuildEstimateCmd -- TODO change type
       firstExceptT TxCmdMetadataError
         . newExceptT
         $ readTxMetadata sbe metadataSchema metadataFiles
-    valuesWithScriptWits <- readValueScriptWitnesses sbe $ fromMaybe mempty mValue
+    valuesWithScriptWits <- readMintScriptWitnesses sbe (const undefined) $ fromMaybe mempty mValue
     scripts <-
       firstExceptT TxCmdScriptFileError $
         mapM (readFileScriptInAnyLang . unFile) scriptFiles
@@ -594,7 +596,7 @@ runTransactionBuildRawCmd
       firstExceptT TxCmdMetadataError
         . newExceptT
         $ readTxMetadata eon metadataSchema metadataFiles
-    valuesWithScriptWits <- readValueScriptWitnesses eon $ fromMaybe mempty mValue
+    valuesWithScriptWits <- readMintScriptWitnesses eon (const undefined) $ fromMaybe mempty mValue
     scripts <-
       firstExceptT TxCmdScriptFileError $
         mapM (readFileScriptInAnyLang . unFile) scriptFiles
@@ -698,7 +700,7 @@ runTxBuildRaw
   -- ^ Tx upper bound
   -> Lovelace
   -- ^ Tx fee
-  -> (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)])
+  -> (Value, [UpdatedReferenceScriptWitness era])
   -- ^ Multi-Asset value(s)
   -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))]
   -- ^ Certificate with potential script witness
@@ -784,7 +786,7 @@ constructTxBodyContent
   -- ^ Tx lower bound
   -> TxValidityUpperBound era
   -- ^ Tx upper bound
-  -> (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)])
+  -> (Value, [UpdatedReferenceScriptWitness era])
   -- ^ Multi-Asset value(s)
   -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))]
   -- ^ Certificate with potential script witness
@@ -831,7 +833,7 @@ constructTxBodyContent
       let allReferenceInputs =
             getAllReferenceInputs
               inputsAndMaybeScriptWits
-              (snd <$> snd valuesWithScriptWits)
+              (snd valuesWithScriptWits)
               certsAndMaybeScriptWits
               withdrawals
               votingProcedures
@@ -924,7 +926,7 @@ runTxBuild
   -- ^ Normal outputs
   -> TxOutChangeAddress
   -- ^ A change output
-  -> (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)])
+  -> (Value, [UpdatedReferenceScriptWitness era])
   -- ^ Multi-Asset value(s)
   -> Maybe SlotNo
   -- ^ Tx lower bound
@@ -978,7 +980,7 @@ runTxBuild
       let allReferenceInputs =
             getAllReferenceInputs
               inputsAndMaybeScriptWits
-              (snd <$> snd valuesWithScriptWits)
+              (snd valuesWithScriptWits)
               certsAndMaybeScriptWits
               withdrawals
               votingProcedures
@@ -1145,7 +1147,7 @@ validateTxInsReference sbe allRefIns = do
 
 getAllReferenceInputs
   :: [(TxIn, Maybe (ScriptWitness WitCtxTxIn era))]
-  -> [ScriptWitness WitCtxMint era]
+  -> [UpdatedReferenceScriptWitness era]
   -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))]
   -> [(StakeAddress, Lovelace, Maybe (ScriptWitness WitCtxStake era))]
   -> [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))]
@@ -1162,7 +1164,7 @@ getAllReferenceInputs
   propProceduresAnMaybeScriptWits
   readOnlyRefIns = do
     let txinsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- txins]
-        mintingRefInputs = map getReferenceInput mintWitnesses
+        mintingRefInputs = [getReferenceInput sWit | UpdatedReferenceScriptWitness _ sWit <- mintWitnesses]
         certsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- certFiles]
         withdrawalsWitByRefInputs = [getReferenceInput sWit | (_, _, Just sWit) <- withdrawals]
         votesWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- votingProceduresAndMaybeScriptWits]
@@ -1329,7 +1331,7 @@ toTxAlonzoDatum supp cliDatum =
 createTxMintValue
   :: forall era
    . ShelleyBasedEra era
-  -> (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)])
+  -> (Value, [UpdatedReferenceScriptWitness era])
   -> Either TxCmdError (TxMintValue BuildTx era)
 createTxMintValue era (val, scriptWitnesses) =
   if List.null (toList val) && List.null scriptWitnesses
@@ -1346,7 +1348,9 @@ createTxMintValue era (val, scriptWitnesses) =
                 witnessesNeededSet = fromList [pid | (pid, _, _) <- policiesWithAssets]
 
                 witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era)
-                witnessesProvidedMap = fromList $ gatherMintingWitnesses scriptWitnesses
+                witnessesProvidedMap =
+                  fromList
+                    [(policyId', sWit) | UpdatedReferenceScriptWitness (Just policyId') sWit <- scriptWitnesses]
                 witnessesProvidedSet = Map.keysSet witnessesProvidedMap
 
                 policiesWithWitnesses =
@@ -1363,15 +1367,6 @@ createTxMintValue era (val, scriptWitnesses) =
         )
         era
  where
-  gatherMintingWitnesses
-    :: [(Maybe PolicyId, ScriptWitness WitCtxMint era)]
-    -> [(PolicyId, ScriptWitness WitCtxMint era)]
-  gatherMintingWitnesses [] = []
-  gatherMintingWitnesses ((mPid, sWit) : rest) =
-    case scriptWitnessPolicyId sWit <|> mPid of
-      Nothing -> gatherMintingWitnesses rest
-      Just pid -> (pid, sWit) : gatherMintingWitnesses rest
-
   validateAllWitnessesProvided witnessesNeeded witnessesProvided
     | null witnessesMissing = return ()
     | otherwise = Left (TxCmdPolicyIdsMissing witnessesMissing (toList witnessesProvided))
@@ -1384,23 +1379,56 @@ createTxMintValue era (val, scriptWitnesses) =
    where
     witnessesExtra = Set.elems (witnessesProvided Set.\\ witnessesNeeded)
 
-scriptWitnessPolicyId :: ScriptWitness witctx era -> Maybe PolicyId
-scriptWitnessPolicyId (SimpleScriptWitness _ (SScript script)) =
-  Just . scriptPolicyId $ SimpleScript script
-scriptWitnessPolicyId (SimpleScriptWitness _ (SReferenceScript _)) =
-  Nothing
-scriptWitnessPolicyId (PlutusScriptWitness _ version (PScript script) _ _ _) =
-  Just . scriptPolicyId $ PlutusScript version script
-scriptWitnessPolicyId (PlutusScriptWitness _ _ (PReferenceScript _) _ _ _) =
-  Nothing
-
-readValueScriptWitnesses
+-- TOOD remove
+
+readMintScriptWitnesses
   :: ShelleyBasedEra era
-  -> (Value, [ScriptWitnessFiles WitCtxMint])
-  -> ExceptT TxCmdError IO (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)])
-readValueScriptWitnesses era (v, sWitFiles) = do
-  sWits <- mapM (firstExceptT TxCmdScriptWitnessError . readScriptWitness era) sWitFiles
-  return (v, sWits)
+  -> ( TxIn
+       -> ExceptT
+            QueryConvenienceError
+            IO
+            (Maybe (TxOut CtxUTxO era))
+     )
+  -> (a, [ScriptWitnessFiles WitCtxMint])
+  -> ExceptT
+      TxCmdError
+      IO
+      (a, [UpdatedReferenceScriptWitness era])
+readMintScriptWitnesses era getUtxo (v, sWitFiles) =
+  fmap (v,) . forM sWitFiles $ \witFile -> do
+    wit <- firstExceptT TxCmdScriptWitnessError $ readScriptWitness era witFile
+    let mFilePid = getScriptWitnessPolicyId wit
+    mPid <- getPolicyIdFromWitnessOrCliArg witFile
+    pure $ UpdatedReferenceScriptWitness (mPid <|> mFilePid) wit
+ where
+  -- get policy id from the script
+  getScriptWitnessPolicyId :: ScriptWitness WitCtxMint era -> Maybe PolicyId
+  getScriptWitnessPolicyId = \case
+    SimpleScriptWitness _ (SScript script) -> Just . scriptPolicyId $ SimpleScript script
+    SimpleScriptWitness _ (SReferenceScript _) -> Nothing
+    PlutusScriptWitness _ version (PScript script) _ _ _ -> Just . scriptPolicyId $ PlutusScript version script
+    PlutusScriptWitness _ _ (PReferenceScript _) _ _ _ -> Nothing
+
+  -- get policy id using TxIn reference, getting script from UTXO, or using the provided one on the CLI
+  getPolicyIdFromWitnessOrCliArg
+    :: ScriptWitnessFiles WitCtxMint -> ExceptT TxCmdError IO (Maybe PolicyId)
+  getPolicyIdFromWitnessOrCliArg = \case
+    SimpleScriptWitnessFile{} -> pure Nothing
+    PlutusScriptWitnessFiles{} -> pure Nothing
+    PlutusReferenceScriptWitnessFiles _ _ _ _ _ (ConcretePolicyId pid) -> pure $ Just pid
+    PlutusReferenceScriptWitnessFiles txIn _ _ _ _ QueryUtxoPolicyId -> getPolicyIdFromTxOut txIn
+    SimpleReferenceScriptWitnessFiles _ _ (ConcretePolicyId pid) -> pure $ Just pid
+    SimpleReferenceScriptWitnessFiles txIn _ QueryUtxoPolicyId -> getPolicyIdFromTxOut txIn
+
+  -- get policy id from the UTXO
+  getPolicyIdFromTxOut :: TxIn -> ExceptT TxCmdError IO (Maybe PolicyId)
+  getPolicyIdFromTxOut txIn = do
+    txout <- firstExceptT TxCmdQueryConvenienceError $ getUtxo txIn
+    pure $
+      txout >>= \(TxOut _ _ _ refScript) ->
+        case refScript of
+          ReferenceScriptNone -> Nothing
+          ReferenceScript _ (ScriptInAnyLang _ script) -> Just $ scriptPolicyId script
 
 -- ----------------------------------------------------------------------------
 -- Transaction signing

diff --git a/cardano-cli/src/Cardano/CLI/Read.hs b/cardano-cli/src/Cardano/CLI/Read.hs
@@ -272,7 +272,7 @@ readScriptWitnessFiles
 readScriptWitnessFiles era = mapM readSwitFile
  where
   readSwitFile (tIn, Just switFile) = do
-    sWit <- snd <$> readScriptWitness era switFile
+    sWit <- readScriptWitness era switFile
     return (tIn, Just sWit)
   readSwitFile (tIn, Nothing) = return (tIn, Nothing)
 
@@ -283,22 +283,25 @@ readScriptWitnessFilesTuple
 readScriptWitnessFilesTuple era = mapM readSwitFile
  where
   readSwitFile (tIn, b, Just switFile) = do
-    sWit <- snd <$> readScriptWitness era switFile
+    sWit <- readScriptWitness era switFile
     return (tIn, b, Just sWit)
   readSwitFile (tIn, b, Nothing) = return (tIn, b, Nothing)
 
 readScriptWitness
   :: ShelleyBasedEra era
   -> ScriptWitnessFiles witctx
-  -> ExceptT ScriptWitnessError IO (Maybe PolicyId, ScriptWitness witctx era)
+  -> ExceptT
+      ScriptWitnessError
+      IO
+      (ScriptWitness witctx era)
 readScriptWitness era (SimpleScriptWitnessFile (File scriptFile)) = do
   script@(ScriptInAnyLang lang _) <-
     firstExceptT ScriptWitnessErrorFile $
       readFileScriptInAnyLang scriptFile
   ScriptInEra langInEra script' <- validateScriptSupportedInEra era script
   case script' of
     SimpleScript sscript ->
-      return . (Nothing,) . SimpleScriptWitness langInEra $ SScript sscript
+      return . SimpleScriptWitness langInEra $ SScript sscript
     -- If the supplied cli flags were for a simple script (i.e. the user did
     -- not supply the datum, redeemer or ex units), but the script file turns
     -- out to be a valid plutus script, then we must fail.
@@ -327,7 +330,7 @@ readScriptWitness
         redeemer <-
           firstExceptT ScriptWitnessErrorScriptData $
             readScriptRedeemerOrFile redeemerOrFile
-        pure . (Nothing,) $
+        pure $
           PlutusScriptWitness
             langInEra
             version
@@ -352,7 +355,7 @@ readScriptWitness
       datumOrFile
       redeemerOrFile
       execUnits
-      mPid
+      _
     ) = do
     caseShelleyToAlonzoOrBabbageEraOnwards
       ( const $
@@ -375,7 +378,7 @@ readScriptWitness
                   redeemer <-
                     firstExceptT ScriptWitnessErrorScriptData $
                       readScriptRedeemerOrFile redeemerOrFile
-                  return . (mPid,) $
+                  return $
                     PlutusScriptWitness
                       sLangInEra
                       version
@@ -393,7 +396,7 @@ readScriptWitness
   ( SimpleReferenceScriptWitnessFiles
       refTxIn
       anyScrLang@(AnyScriptLanguage anyScriptLanguage)
-      mPid
+      _pid
     ) = do
     caseShelleyToAlonzoOrBabbageEraOnwards
       ( const $
@@ -406,7 +409,7 @@ readScriptWitness
             Just sLangInEra ->
               case languageOfScriptLanguageInEra sLangInEra of
                 SimpleScriptLanguage ->
-                  return . (mPid,) . SimpleScriptWitness sLangInEra $
+                  return . SimpleScriptWitness sLangInEra $
                     SReferenceScript refTxIn
                 PlutusScriptLanguage{} ->
                   error "readScriptWitness: Should not be possible to specify a plutus script"
@@ -922,9 +925,8 @@ readSingleVote w (voteFp, mScriptWitFiles) = do
       let sbe = conwayEraOnwardsToShelleyBasedEra w
       runExceptT $ do
         sWits <-
-          fmap (fmap snd) $
-            firstExceptT VoteErrorScriptWitness $
-              mapM (readScriptWitness sbe) sWitFile
+          firstExceptT VoteErrorScriptWitness $
+            mapM (readScriptWitness sbe) sWitFile
         hoistEither $ (,sWits) <$> votProceds
 
 data ConstitutionError
@@ -969,9 +971,8 @@ readProposal w (fp, mScriptWit) = do
       let sbe = conwayEraOnwardsToShelleyBasedEra w
       runExceptT $ do
         sWit <-
-          fmap (fmap snd) $
-            firstExceptT ProposalErrorScriptWitness $
-              mapM (readScriptWitness sbe) sWitFile
+          firstExceptT ProposalErrorScriptWitness $
+            mapM (readScriptWitness sbe) sWitFile
         hoistEither $ (,sWit) <$> prop
 
 constitutionHashSourceToHash