Add getScriptWitnessScript, getScriptWitnessReferenceInput, getScript…

…WitnessReferenceInputOrScript functions

cardano-api/internal/Cardano/Api/Script.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -47,22 +48,22 @@ module Cardano.Api.Script
     -- * Reference scripts
   , ReferenceScript (..)
   , refScriptToShelleyScript
-  , getScriptWitnessReferenceInput
 
     -- * Use of a script in an era as a witness
   , WitCtxTxIn
   , WitCtxMint
   , WitCtxStake
   , WitCtx (..)
-  , WitCtxMaybe (..)
   , ScriptWitness (..)
+  , getScriptWitnessReferenceInput
+  , getScriptWitnessScript
+  , getScriptWitnessReferenceInputOrScript
   , Witness (..)
   , KeyWitnessInCtx (..)
   , ScriptWitnessInCtx (..)
   , IsScriptWitnessInCtx (..)
   , ScriptDatum (..)
   , ScriptRedeemer
-  , scriptWitnessScript
 
     -- ** Languages supported in each era
   , ScriptLanguageInEra (..)
@@ -680,42 +681,20 @@ data WitCtx witctx where
   WitCtxMint :: WitCtx WitCtxMint
   WitCtxStake :: WitCtx WitCtxStake
 
--- TODO: not needed anymore - remove
-
--- | A typed version of a 'Maybe'. Allows to store value of type @a@ when @purpose ~ witctx@, otherwise it is empty.
-data WitCtxMaybe purpose witctx a where
-  WitCtxJust :: WitCtx purpose -> a -> WitCtxMaybe purpose purpose a
-  WitCtxNothing :: (purpose == witctx) ~ False => WitCtxMaybe purpose witctx a
-
-instance Show a => Show (WitCtxMaybe p w a) where
-  show (WitCtxJust _ a) = "WitCtxJust " <> show a
-  show WitCtxNothing = "WitCtxNothing"
-
 -- | Scripts can now exist in the UTxO at a transaction output. We can
 -- reference these scripts via specification of a reference transaction input
 -- in order to witness spending inputs, withdrawals, certificates
 -- or to mint tokens. This datatype encapsulates this concept.
 data PlutusScriptOrReferenceInput lang
   = PScript (PlutusScript lang)
-  | -- | Needed to construct the redeemer pointer map
-    -- in the case of minting reference scripts where we don't
-    -- have direct access to the script
-    PReferenceScript TxIn
+  | PReferenceScript TxIn
   deriving (Eq, Show)
 
 data SimpleScriptOrReferenceInput lang
   = SScript SimpleScript
   | SReferenceScript TxIn
   deriving (Eq, Show)
 
-getScriptWitnessReferenceInput :: ScriptWitness witctx era -> Maybe TxIn
-getScriptWitnessReferenceInput (SimpleScriptWitness _ (SReferenceScript txIn)) =
-  Just txIn
-getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PReferenceScript txIn) _ _ _) =
-  Just txIn
-getScriptWitnessReferenceInput (SimpleScriptWitness _ (SScript _)) = Nothing
-getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PScript _) _ _ _) = Nothing
-
 -- | A /use/ of a script within a transaction body to witness that something is
 -- being used in an authorised manner. That can be
 --
@@ -796,28 +775,26 @@ deriving instance Eq (ScriptDatum witctx)
 
 deriving instance Show (ScriptDatum witctx)
 
--- We cannot always extract a script from a script witness due to reference scripts.
+getScriptWitnessReferenceInput :: ScriptWitness witctx era -> Maybe TxIn
+getScriptWitnessReferenceInput = either (const Nothing) Just . getScriptWitnessReferenceInputOrScript
+
+getScriptWitnessScript :: ScriptWitness witctx era -> Maybe (ScriptInEra era)
+getScriptWitnessScript = either Just (const Nothing) . getScriptWitnessReferenceInputOrScript
+
+-- | We cannot always extract a script from a script witness due to reference scripts.
 -- Reference scripts exist in the UTxO, so without access to the UTxO we cannot
 -- retrieve the script.
-scriptWitnessScript :: ScriptWitness witctx era -> Maybe (ScriptInEra era)
-scriptWitnessScript (SimpleScriptWitness SimpleScriptInShelley (SScript script)) =
-  Just $ ScriptInEra SimpleScriptInShelley (SimpleScript script)
-scriptWitnessScript (SimpleScriptWitness SimpleScriptInAllegra (SScript script)) =
-  Just $ ScriptInEra SimpleScriptInAllegra (SimpleScript script)
-scriptWitnessScript (SimpleScriptWitness SimpleScriptInMary (SScript script)) =
-  Just $ ScriptInEra SimpleScriptInMary (SimpleScript script)
-scriptWitnessScript (SimpleScriptWitness SimpleScriptInAlonzo (SScript script)) =
-  Just $ ScriptInEra SimpleScriptInAlonzo (SimpleScript script)
-scriptWitnessScript (SimpleScriptWitness SimpleScriptInBabbage (SScript script)) =
-  Just $ ScriptInEra SimpleScriptInBabbage (SimpleScript script)
-scriptWitnessScript (SimpleScriptWitness SimpleScriptInConway (SScript script)) =
-  Just $ ScriptInEra SimpleScriptInConway (SimpleScript script)
-scriptWitnessScript (PlutusScriptWitness langInEra version (PScript script) _ _ _) =
-  Just $ ScriptInEra langInEra (PlutusScript version script)
-scriptWitnessScript (SimpleScriptWitness _ (SReferenceScript _)) =
-  Nothing
-scriptWitnessScript (PlutusScriptWitness _ _ (PReferenceScript _) _ _ _) =
-  Nothing
+-- So in the cases for script reference, the result contains @Right TxIn@.
+getScriptWitnessReferenceInputOrScript :: ScriptWitness witctx era -> Either (ScriptInEra era) TxIn
+getScriptWitnessReferenceInputOrScript = \case
+  SimpleScriptWitness (s :: (ScriptLanguageInEra SimpleScript' era)) (SScript script) ->
+    Left $ ScriptInEra s (SimpleScript script)
+  PlutusScriptWitness langInEra version (PScript script) _ _ _ ->
+    Left $ ScriptInEra langInEra (PlutusScript version script)
+  SimpleScriptWitness _ (SReferenceScript txIn) ->
+    Right txIn
+  PlutusScriptWitness _ _ (PReferenceScript txIn) _ _ _ ->
+    Right txIn
 
 -- ----------------------------------------------------------------------------
 -- The kind of witness to use, key (signature) or script

cardano-api/internal/Cardano/Api/Tx/Body.hs

@@ -183,7 +183,6 @@ module Cardano.Api.Tx.Body
   , guardShelleyTxInsOverflow
   , validateTxOuts
   , validateMetadata
-  , validateMintValue
   , validateTxInsCollateral
   , validateProtocolParameters
   )
@@ -1274,6 +1273,7 @@ txMintValueToValue (TxMintValue _ policiesWithAssets) =
     ]
 
 -- | Index the assets with witnesses in the order of policy ids.
+-- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf
 txMintValueToIndexed
   :: TxMintValue build era
   -> [ ( ScriptWitnessIndex
@@ -1587,7 +1587,6 @@ data TxBodyError
   | TxBodyOutputNegative !Quantity !TxOutInAnyEra
   | TxBodyOutputOverflow !Quantity !TxOutInAnyEra
   | TxBodyMetadataError ![(Word64, TxMetadataRangeError)]
-  | TxBodyMintAdaError -- TODO remove - case nonexistent
   | TxBodyInIxOverflow !TxIn
   | TxBodyMissingProtocolParams
   | TxBodyProtocolParamsConversionError !ProtocolParametersConversionError
@@ -1623,8 +1622,6 @@ instance Error TxBodyError where
               | (k, err) <- errs
               ]
         ]
-    TxBodyMintAdaError ->
-      "Transaction cannot mint ada, only non-ada assets"
     TxBodyMissingProtocolParams ->
       "Transaction uses Plutus scripts but does not provide the protocol "
         <> "parameters to hash"
@@ -1786,28 +1783,24 @@ validateTxBodyContent
             guardShelleyTxInsOverflow (map fst txIns)
             validateTxOuts sbe txOuts
             validateMetadata txMetadata
-            validateMintValue txMintValue
           ShelleyBasedEraAlonzo -> do
             validateTxIns txIns
             guardShelleyTxInsOverflow (map fst txIns)
             validateTxOuts sbe txOuts
             validateMetadata txMetadata
-            validateMintValue txMintValue
             validateTxInsCollateral txInsCollateral languages
             validateProtocolParameters txProtocolParams languages
           ShelleyBasedEraBabbage -> do
             validateTxIns txIns
             guardShelleyTxInsOverflow (map fst txIns)
             validateTxOuts sbe txOuts
             validateMetadata txMetadata
-            validateMintValue txMintValue
             validateTxInsCollateral txInsCollateral languages
             validateProtocolParameters txProtocolParams languages
           ShelleyBasedEraConway -> do
             validateTxIns txIns
             validateTxOuts sbe txOuts
             validateMetadata txMetadata
-            validateMintValue txMintValue
             validateTxInsCollateral txInsCollateral languages
             validateProtocolParameters txProtocolParams languages
 
@@ -1856,10 +1849,6 @@ validateTxOuts sbe txOuts = do
       | txout@(TxOut _ v _ _) <- txOuts
       ]
 
--- TODO remove
-validateMintValue :: TxMintValue build era -> Either TxBodyError ()
-validateMintValue _txMintValue = pure ()
-
 inputIndexDoesNotExceedMax :: [(TxIn, a)] -> Either TxBodyError ()
 inputIndexDoesNotExceedMax txIns =
   for_ txIns $ \(txin@(TxIn _ (TxIx txix)), _) ->
@@ -2463,7 +2452,7 @@ convScripts
   -> [Ledger.Script ledgerera]
 convScripts scriptWitnesses =
   catMaybes
-    [ toShelleyScript <$> scriptWitnessScript scriptwitness
+    [ toShelleyScript <$> getScriptWitnessScript scriptwitness
     | (_, AnyScriptWitness scriptwitness) <- scriptWitnesses
     ]
 
@@ -2630,7 +2619,7 @@ makeShelleyTransactionBody
     scripts_ :: [Ledger.Script StandardShelley]
     scripts_ =
       catMaybes
-        [ toShelleyScript <$> scriptWitnessScript scriptwitness
+        [ toShelleyScript <$> getScriptWitnessScript scriptwitness
         | (_, AnyScriptWitness scriptwitness) <-
             collectTxBodyScriptWitnesses sbe txbodycontent
         ]
@@ -2675,7 +2664,7 @@ makeShelleyTransactionBody
     scripts_ :: [Ledger.Script StandardAllegra]
     scripts_ =
       catMaybes
-        [ toShelleyScript <$> scriptWitnessScript scriptwitness
+        [ toShelleyScript <$> getScriptWitnessScript scriptwitness
         | (_, AnyScriptWitness scriptwitness) <-
             collectTxBodyScriptWitnesses sbe txbodycontent
         ]
@@ -2724,7 +2713,7 @@ makeShelleyTransactionBody
     scripts =
       List.nub $
         catMaybes
-          [ toShelleyScript <$> scriptWitnessScript scriptwitness
+          [ toShelleyScript <$> getScriptWitnessScript scriptwitness
           | (_, AnyScriptWitness scriptwitness) <-
               collectTxBodyScriptWitnesses sbe txbodycontent
           ]
@@ -2789,7 +2778,7 @@ makeShelleyTransactionBody
     scripts =
       List.nub $
         catMaybes
-          [ toShelleyScript <$> scriptWitnessScript scriptwitness
+          [ toShelleyScript <$> getScriptWitnessScript scriptwitness
           | (_, AnyScriptWitness scriptwitness) <- witnesses
           ]
 
@@ -2910,7 +2899,7 @@ makeShelleyTransactionBody
     scripts =
       List.nub $
         catMaybes
-          [ toShelleyScript <$> scriptWitnessScript scriptwitness
+          [ toShelleyScript <$> getScriptWitnessScript scriptwitness
           | (_, AnyScriptWitness scriptwitness) <- witnesses
           ]
 
@@ -3049,7 +3038,7 @@ makeShelleyTransactionBody
     scripts :: [Ledger.Script StandardConway]
     scripts =
       catMaybes
-        [ toShelleyScript <$> scriptWitnessScript scriptwitness
+        [ toShelleyScript <$> getScriptWitnessScript scriptwitness
         | (_, AnyScriptWitness scriptwitness) <- witnesses
         ]
 

cardano-api/src/Cardano/Api.hs

@@ -537,15 +537,16 @@ module Cardano.Api
   , WitCtxMint
   , WitCtxStake
   , WitCtx (..)
-  , WitCtxMaybe (..)
   , ScriptWitness (..)
+  , getScriptWitnessScript
+  , getScriptWitnessReferenceInput
+  , getScriptWitnessReferenceInputOrScript
   , Witness (..)
   , KeyWitnessInCtx (..)
   , ScriptWitnessInCtx (..)
   , IsScriptWitnessInCtx (..)
   , ScriptDatum (..)
   , ScriptRedeemer
-  , scriptWitnessScript
 
     -- ** Inspecting 'ScriptWitness'es
   , AnyScriptWitness (..)

cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs

@@ -355,7 +355,6 @@ test_TxBodyError =
     , ("TxBodyOutputNegative", TxBodyOutputNegative 1 txOutInAnyEra1)
     , ("TxBodyOutputOverflow", TxBodyOutputOverflow 1 txOutInAnyEra1)
     , ("TxBodyMetadataError", TxBodyMetadataError [(1, TxMetadataBytesTooLong 2)])
-    , ("TxBodyMintAdaError", TxBodyMintAdaError)
     , ("TxBodyMissingProtocolParams", TxBodyMissingProtocolParams)
     , ("TxBodyInIxOverflow", TxBodyInIxOverflow txin1)
     ]