more wip

IntersectMBO · Nov 7, 2024 · 4d6beff · 4d6beff
1 parent c461679
commit 4d6beff
Show file tree

Hide file tree

Showing 4 changed files with 88 additions and 55 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 $ 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 $ 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 $ 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
@@ -1364,10 +1366,14 @@ createTxMintValue era (val, scriptWitnesses) =
         era
  where
   gatherMintingWitnesses
-    :: [(Maybe PolicyId, ScriptWitness WitCtxMint era)]
+    :: [UpdatedReferenceScriptWitness era]
     -> [(PolicyId, ScriptWitness WitCtxMint era)]
   gatherMintingWitnesses [] = []
-  gatherMintingWitnesses ((mPid, sWit) : rest) =
+  gatherMintingWitnesses (UpdatedReferenceScriptWitness mPidSource sWit : rest) = do
+    let mPid =
+          mPidSource >>= \case
+            ConcretePolicyId pid -> Just pid
+            QueryUtxoPolicyId _ -> Nothing -- TODO
     case scriptWitnessPolicyId sWit <|> mPid of
       Nothing -> gatherMintingWitnesses rest
       Just pid -> (pid, sWit) : gatherMintingWitnesses rest
@@ -1384,23 +1390,31 @@ 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
+  scriptWitnessPolicyId :: ScriptWitness WitCtxMint era -> Maybe PolicyId
+  scriptWitnessPolicyId = \case
+    SimpleScriptWitness _ (SScript script) -> Just . scriptPolicyId $ SimpleScript script
+    SimpleScriptWitness _ (SReferenceScript _) -> Nothing
+    PlutusScriptWitness _ version (PScript script) _ _ _ -> Just . scriptPolicyId $ PlutusScript version script
+    PlutusScriptWitness _ _ (PReferenceScript _) _ _ _ -> Nothing
+
+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)
+  -> (a, [ScriptWitnessFiles WitCtxMint])
+  -> ExceptT
+      TxCmdError
+      IO
+      (a, [UpdatedReferenceScriptWitness era])
+readMintScriptWitnesses era (v, sWitFiles) =
+  firstExceptT TxCmdScriptWitnessError $
+    fmap (v,) . forM sWitFiles $ \witFile -> do
+      wit <- readScriptWitness era witFile
+      pure $ UpdatedReferenceScriptWitness Nothing wit
+
+getpid = undefined :: ScriptWitness WitCtxMint era -> PolicyId
+
+setpid = undefined :: PolicyId -> ScriptWitness WitCtxMint era -> ScriptWitness WitCtxMint era
+
+foo = Proxy @SimpleScriptWitness
 
 -- ----------------------------------------------------------------------------
 -- 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