diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 17ba9f950a0..37443162a56 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -72,6 +72,7 @@ library Cardano.Api.ProtocolParameters Cardano.Api.Query Cardano.Api.Script + Cardano.Api.ScriptData Cardano.Api.SerialiseBech32 Cardano.Api.SerialiseCBOR Cardano.Api.SerialiseJSON diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index eaef670b662..e44790882ac 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -16,6 +16,7 @@ module Cardano.Api ( ShelleyEra, AllegraEra, MaryEra, + AlonzoEra, CardanoEra(..), IsCardanoEra(..), AnyCardanoEra(..), @@ -105,6 +106,7 @@ module Cardano.Api ( -- ** Multi-asset values Quantity(..), PolicyId(..), + scriptPolicyId, AssetName(..), AssetId(..), Value, @@ -198,6 +200,7 @@ module Cardano.Api ( TxMetadataSupportedInEra(..), AuxScriptsSupportedInEra(..), TxExtraKeyWitnessesSupportedInEra(..), + ScriptDataSupportedInEra(..), WithdrawalsSupportedInEra(..), CertificatesSupportedInEra(..), UpdateProposalSupportedInEra(..), @@ -215,6 +218,7 @@ module Cardano.Api ( withdrawalsSupportedInEra, certificatesSupportedInEra, updateProposalSupportedInEra, + scriptDataSupportedInEra, -- * Signing transactions -- | Creating transaction witnesses one by one, or all in one go. @@ -310,12 +314,14 @@ module Cardano.Api ( -- * Use of a script in an era as a witness WitCtxTxIn, WitCtxMint, WitCtxStake, + WitCtx(..), ScriptWitness(..), Witness(..), KeyWitnessInCtx(..), ScriptWitnessInCtx(..), ScriptDatum(..), ScriptRedeemer, + scriptWitnessScript, -- *** Languages supported in each era ScriptLanguageInEra(..), @@ -332,10 +338,26 @@ module Cardano.Api ( -- ** Plutus scripts PlutusScript, + examplePlutusScriptAlwaysSucceeds, + examplePlutusScriptAlwaysFails, - -- ** Script data + -- * Script data ScriptData(..), + -- ** Validation + ScriptDataRangeError (..), + validateScriptData, + + -- ** Conversion to\/from JSON + ScriptDataJsonSchema (..), + scriptDataFromJson, + scriptDataToJson, + ScriptDataJsonError (..), + ScriptDataJsonSchemaError (..), + + -- * Script execution units + ExecutionUnits(..), + -- ** Script addresses -- | Making addresses from scripts. ScriptHash, @@ -545,6 +567,7 @@ import Cardano.Api.OperationalCertificate import Cardano.Api.ProtocolParameters import Cardano.Api.Query (SlotsInEpoch(..), SlotsToEpochEnd(..), slotToEpoch) import Cardano.Api.Script +import Cardano.Api.ScriptData import Cardano.Api.SerialiseBech32 import Cardano.Api.SerialiseCBOR import Cardano.Api.SerialiseJSON diff --git a/cardano-api/src/Cardano/Api/Script.hs b/cardano-api/src/Cardano/Api/Script.hs index 9aa97f4d084..1340a2fd30a 100644 --- a/cardano-api/src/Cardano/Api/Script.hs +++ b/cardano-api/src/Cardano/Api/Script.hs @@ -33,6 +33,7 @@ module Cardano.Api.Script ( -- * Use of a script in an era as a witness WitCtxTxIn, WitCtxMint, WitCtxStake, + WitCtx(..), ScriptWitness(..), Witness(..), KeyWitnessInCtx(..), @@ -55,6 +56,8 @@ module Cardano.Api.Script ( -- * The Plutus script language PlutusScript(..), + examplePlutusScriptAlwaysSucceeds, + examplePlutusScriptAlwaysFails, -- * Script data ScriptData(..), @@ -92,7 +95,6 @@ module Cardano.Api.Script ( import Prelude import Data.Word (Word64) -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as SBS @@ -104,6 +106,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) import Data.Typeable (Typeable) +import Numeric.Natural (Natural) import Data.Aeson (Value (..), object, (.:), (.=)) import qualified Data.Aeson as Aeson @@ -124,23 +127,22 @@ import Cardano.Slotting.Slot (SlotNo) import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Era as Ledger -import qualified Cardano.Ledger.SafeHash as Ledger import qualified Cardano.Ledger.ShelleyMA.Timelocks as Timelock import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) import qualified Cardano.Ledger.Keys as Shelley import qualified Shelley.Spec.Ledger.Scripts as Shelley -import qualified Cardano.Ledger.Alonzo.Data as Alonzo import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo -import qualified Plutus.V1.Ledger.Api as Plutus +import qualified Plutus.V1.Ledger.Examples as Plutus import Cardano.Api.Eras import Cardano.Api.HasTypeProxy import Cardano.Api.Hash import Cardano.Api.KeysShelley +import Cardano.Api.ScriptData import Cardano.Api.SerialiseCBOR import Cardano.Api.SerialiseJSON import Cardano.Api.SerialiseRaw @@ -599,6 +601,17 @@ data WitCtxMint -- data WitCtxStake + +-- | This GADT provides a value-level representation of all the witness +-- contexts. This enables pattern matching on the context to allow them to be +-- treated in a non-uniform way. +-- +data WitCtx witctx where + WitCtxTxIn :: WitCtx WitCtxTxIn + WitCtxMint :: WitCtx WitCtxMint + WitCtxStake :: WitCtx WitCtxStake + + -- | A /use/ of a script within a transaction body to witness that something is -- being used in an authorised manner. That can be -- @@ -653,6 +666,8 @@ instance Eq (ScriptWitness witctx era) where (==) _ _ = False +type ScriptRedeemer = ScriptData + data ScriptDatum witctx where ScriptDatumForTxIn :: ScriptData -> ScriptDatum WitCtxTxIn NoScriptDatumForMint :: ScriptDatum WitCtxMint @@ -704,77 +719,6 @@ deriving instance Eq (ScriptWitnessInCtx witctx) deriving instance Show (ScriptWitnessInCtx witctx) --- ---------------------------------------------------------------------------- --- Script data --- - -type ScriptRedeemer = ScriptData - -data ScriptData = ScriptDataConstructor Integer [ScriptData] - | ScriptDataMap [(ScriptData, ScriptData)] - | ScriptDataList [ScriptData] - | ScriptDataNumber Integer - | ScriptDataBytes BS.ByteString - deriving (Eq, Ord, Show) - -- Note the order of constructors is the same as the Plutus definitions - -- so that the Ord instance is consistent with the Plutus one. - -- This is checked by prop_ord_distributive_ScriptData - -instance HasTypeProxy ScriptData where - data AsType ScriptData = AsScriptData - proxyToAsType _ = AsScriptData - -toAlonzoData :: ScriptData -> Alonzo.Data ledgerera -toAlonzoData = Alonzo.Data . toPlutusData - -fromAlonzoData :: Alonzo.Data ledgerera -> ScriptData -fromAlonzoData = fromPlutusData . Alonzo.getPlutusData - - -toPlutusData :: ScriptData -> Plutus.Data -toPlutusData (ScriptDataConstructor int xs) - = Plutus.Constr int - [ toPlutusData x | x <- xs ] -toPlutusData (ScriptDataMap kvs) = Plutus.Map - [ (toPlutusData k, toPlutusData v) - | (k,v) <- kvs ] -toPlutusData (ScriptDataList xs) = Plutus.List - [ toPlutusData x | x <- xs ] -toPlutusData (ScriptDataNumber n) = Plutus.I n -toPlutusData (ScriptDataBytes bs) = Plutus.B bs - -fromPlutusData :: Plutus.Data -> ScriptData -fromPlutusData (Plutus.Constr int xs) - = ScriptDataConstructor int - [ fromPlutusData x | x <- xs ] -fromPlutusData (Plutus.Map kvs) = ScriptDataMap - [ (fromPlutusData k, fromPlutusData v) - | (k,v) <- kvs ] -fromPlutusData (Plutus.List xs) = ScriptDataList - [ fromPlutusData x | x <- xs ] -fromPlutusData (Plutus.I n) = ScriptDataNumber n -fromPlutusData (Plutus.B bs) = ScriptDataBytes bs - - -newtype instance Hash ScriptData = - ScriptDataHash (Alonzo.DataHash StandardCrypto) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash ScriptData) - -instance SerialiseAsRawBytes (Hash ScriptData) where - serialiseToRawBytes (ScriptDataHash dh) = - Crypto.hashToBytes (Ledger.extractHash dh) - - deserialiseFromRawBytes (AsHash AsScriptData) bs = - ScriptDataHash . Ledger.unsafeMakeSafeHash <$> Crypto.hashFromBytes bs - -instance ToJSON (Hash ScriptData) where - toJSON = toJSON . serialiseToRawBytesHexText - -instance Aeson.ToJSONKey (Hash ScriptData) where - toJSONKey = Aeson.toJSONKeyText serialiseToRawBytesHexText - - -- ---------------------------------------------------------------------------- -- Script execution units -- @@ -997,6 +941,49 @@ instance (IsPlutusScriptLanguage lang, Typeable lang) => PlutusScriptV1 -> "PlutusScriptV1" +-- | An example Plutus script that always succeeds, irrespective of inputs. +-- +-- For example, if one were to use this for a payment address then it would +-- allow anyone to spend from it. +-- +-- The exact script depends on the context in which it is to be used. +-- +examplePlutusScriptAlwaysSucceeds :: WitCtx witctx + -> PlutusScript PlutusScriptV1 +examplePlutusScriptAlwaysSucceeds = + PlutusScriptSerialised + . Plutus.alwaysSucceedingNAryFunction + . scriptArityForWitCtx + +-- | An example Plutus script that always fails, irrespective of inputs. +-- +-- For example, if one were to use this for a payment address then it would +-- be impossible for anyone to ever spend from it. +-- +-- The exact script depends on the context in which it is to be used. +-- +examplePlutusScriptAlwaysFails :: WitCtx witctx + -> PlutusScript PlutusScriptV1 +examplePlutusScriptAlwaysFails = + PlutusScriptSerialised + . Plutus.alwaysFailingNAryFunction + . scriptArityForWitCtx + +-- | The expected arity of the Plutus function, depending on the context in +-- which it is used. +-- +-- The script inputs consist of +-- +-- * the optional datum (for txins) +-- * the redeemer +-- * the Plutus representation of the tx and environment +-- +scriptArityForWitCtx :: WitCtx witctx -> Natural +scriptArityForWitCtx WitCtxTxIn = 3 +scriptArityForWitCtx WitCtxMint = 2 +scriptArityForWitCtx WitCtxStake = 2 + + -- ---------------------------------------------------------------------------- -- Conversion functions -- diff --git a/cardano-api/src/Cardano/Api/ScriptData.hs b/cardano-api/src/Cardano/Api/ScriptData.hs new file mode 100644 index 00000000000..5874333d682 --- /dev/null +++ b/cardano-api/src/Cardano/Api/ScriptData.hs @@ -0,0 +1,564 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Api.ScriptData ( + -- * Script data + ScriptData(..), + + -- * Validating metadata + validateScriptData, + ScriptDataRangeError (..), + + -- * Converstion to\/from JSON + ScriptDataJsonSchema (..), + scriptDataFromJson, + scriptDataToJson, + ScriptDataJsonError (..), + ScriptDataJsonSchemaError (..), + + -- * Internal conversion functions + toPlutusData, + fromPlutusData, + toAlonzoData, + fromAlonzoData, + + -- * Data family instances + AsType(..), + Hash(..), + ) where + +import Prelude + +import Data.Bifunctor (first) +import Data.Maybe (fromMaybe) +import Data.Word +import qualified Data.Scientific as Scientific +import qualified Data.Char as Char +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Base16 as Base16 +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +import qualified Data.Vector as Vector + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Text as Aeson.Text +import qualified Data.Aeson.Types as Aeson +import qualified Data.Attoparsec.ByteString.Char8 as Atto + +import Control.Applicative (Alternative (..)) + +import qualified Cardano.Crypto.Hash.Class as Crypto +import qualified Cardano.Ledger.SafeHash as Ledger +import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) +import qualified Cardano.Ledger.Alonzo.Data as Alonzo +import qualified Plutus.V1.Ledger.Api as Plutus + +import Cardano.Api.Eras +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.KeysShelley +import Cardano.Api.SerialiseJSON +import Cardano.Api.SerialiseRaw +import Cardano.Api.TxMetadata (parseAll, pSigned, pBytes) + + +-- ---------------------------------------------------------------------------- +-- Script data +-- + +data ScriptData = ScriptDataConstructor Integer [ScriptData] + | ScriptDataMap [(ScriptData, ScriptData)] + | ScriptDataList [ScriptData] + | ScriptDataNumber Integer + | ScriptDataBytes BS.ByteString + deriving (Eq, Ord, Show) + -- Note the order of constructors is the same as the Plutus definitions + -- so that the Ord instance is consistent with the Plutus one. + -- This is checked by prop_ord_distributive_ScriptData + +instance HasTypeProxy ScriptData where + data AsType ScriptData = AsScriptData + proxyToAsType _ = AsScriptData + + +-- ---------------------------------------------------------------------------- +-- Script data hash +-- + +newtype instance Hash ScriptData = + ScriptDataHash (Alonzo.DataHash StandardCrypto) + deriving stock (Eq, Ord) + deriving (Show, IsString) via UsingRawBytesHex (Hash ScriptData) + +instance SerialiseAsRawBytes (Hash ScriptData) where + serialiseToRawBytes (ScriptDataHash dh) = + Crypto.hashToBytes (Ledger.extractHash dh) + + deserialiseFromRawBytes (AsHash AsScriptData) bs = + ScriptDataHash . Ledger.unsafeMakeSafeHash <$> Crypto.hashFromBytes bs + +instance ToJSON (Hash ScriptData) where + toJSON = toJSON . serialiseToRawBytesHexText + +instance Aeson.ToJSONKey (Hash ScriptData) where + toJSONKey = Aeson.toJSONKeyText serialiseToRawBytesHexText + + +-- ---------------------------------------------------------------------------- +-- Conversion functions +-- + +toAlonzoData :: ScriptData -> Alonzo.Data ledgerera +toAlonzoData = Alonzo.Data . toPlutusData + +fromAlonzoData :: Alonzo.Data ledgerera -> ScriptData +fromAlonzoData = fromPlutusData . Alonzo.getPlutusData + + +toPlutusData :: ScriptData -> Plutus.Data +toPlutusData (ScriptDataConstructor int xs) + = Plutus.Constr int + [ toPlutusData x | x <- xs ] +toPlutusData (ScriptDataMap kvs) = Plutus.Map + [ (toPlutusData k, toPlutusData v) + | (k,v) <- kvs ] +toPlutusData (ScriptDataList xs) = Plutus.List + [ toPlutusData x | x <- xs ] +toPlutusData (ScriptDataNumber n) = Plutus.I n +toPlutusData (ScriptDataBytes bs) = Plutus.B bs + + +fromPlutusData :: Plutus.Data -> ScriptData +fromPlutusData (Plutus.Constr int xs) + = ScriptDataConstructor int + [ fromPlutusData x | x <- xs ] +fromPlutusData (Plutus.Map kvs) = ScriptDataMap + [ (fromPlutusData k, fromPlutusData v) + | (k,v) <- kvs ] +fromPlutusData (Plutus.List xs) = ScriptDataList + [ fromPlutusData x | x <- xs ] +fromPlutusData (Plutus.I n) = ScriptDataNumber n +fromPlutusData (Plutus.B bs) = ScriptDataBytes bs + + +-- ---------------------------------------------------------------------------- +-- Validate script data +-- + +-- | Validate script data. This is for use with existing constructed script +-- data values, e.g. constructed manually or decoded from CBOR directly. +-- +validateScriptData :: ScriptData -> Either ScriptDataRangeError () +validateScriptData d = + case collect d of + [] -> Right () + err:_ -> Left err + where + -- collect all errors in a monoidal fold style: + collect (ScriptDataNumber n) = + [ ScriptDataNumberOutOfRange n + | n > fromIntegral (maxBound :: Word64) + || n < negate (fromIntegral (maxBound :: Word64)) + ] + collect (ScriptDataBytes bs) = + [ ScriptDataBytesTooLong len + | let len = BS.length bs + , len > scriptDataByteStringMaxLength + ] + collect (ScriptDataList xs) = + foldMap collect xs + + collect (ScriptDataMap kvs) = + foldMap (\(k, v) -> collect k + <> collect v) + kvs + + collect (ScriptDataConstructor n xs) = + [ ScriptDataConstructorOutOfRange n + | n > fromIntegral (maxBound :: Word64) || n < 0 ] + <> foldMap collect xs + + +-- | The maximum length of a script data byte string value. +scriptDataByteStringMaxLength :: Int +scriptDataByteStringMaxLength = 64 + + +-- | An error in script data due to an out-of-range value. +-- +data ScriptDataRangeError = + + -- | The number is outside the maximum range of @-2^64-1 .. 2^64-1@. + -- + ScriptDataNumberOutOfRange !Integer + + -- | The number is outside the maximum range of @-2^64-1 .. 2^64-1@. + -- + | ScriptDataConstructorOutOfRange !Integer + + -- | The length of a byte string metadatum value exceeds the maximum of + -- 64 bytes. + -- + | ScriptDataBytesTooLong !Int + deriving (Eq, Show) + +instance Error ScriptDataRangeError where + displayError (ScriptDataNumberOutOfRange n) = + "Number in script data value " + <> show n + <> " is outside the range -(2^64-1) .. 2^64-1." + displayError (ScriptDataConstructorOutOfRange n) = + "Constructor numbers in script data value " + <> show n + <> " is outside the range 0 .. 2^64-1." + displayError (ScriptDataBytesTooLong actualLen) = + "Byte strings in script data must consist of at most " + <> show scriptDataByteStringMaxLength + <> " bytes, but it consists of " + <> show actualLen + <> " bytes." + + +-- ---------------------------------------------------------------------------- +-- JSON conversion +-- + +-- | Script data is similar to JSON but not exactly the same. It has some +-- deliberate limitations such as no support for floating point numbers or +-- special forms for null or boolean values. It also has limitations on the +-- length of strings. On the other hand, unlike JSON, it distinguishes between +-- byte strings and text strings. It also supports any value as map keys rather +-- than just string. It also supports alternatives \/ tagged unions, used for +-- representing constructors for Plutus data values. +-- +-- We provide two different mappings between script data and JSON, useful +-- for different purposes: +-- +-- 1. A mapping that allows almost any JSON value to be converted into script +-- data. This does not require a specific JSON schema for the input. It does +-- not expose the full representation capability of script data. +-- +-- 2. A mapping that exposes the full representation capability of script data, +-- but relies on a specific JSON schema for the input JSON. +-- +-- In the \"no schema"\ mapping, the idea is that (almost) any JSON can be +-- turned into script data and then converted back, without loss. That is, we +-- can round-trip the JSON. +-- +-- The subset of JSON supported is all JSON except: +-- * No null or bool values +-- * No floating point, only integers in the range of a 64bit signed integer +-- * A limitation on string lengths +-- +-- The approach for this mapping is to use whichever representation as script +-- data is most compact. In particular: +-- +-- * JSON lists and maps represented as CBOR lists and maps +-- * JSON strings represented as CBOR strings +-- * JSON hex strings with \"0x\" prefix represented as CBOR byte strings +-- * JSON integer numbers represented as CBOR signed or unsigned numbers +-- * JSON maps with string keys that parse as numbers or hex byte strings, +-- represented as CBOR map keys that are actually numbers or byte strings. +-- +-- The string length limit depends on whether the hex string representation +-- is used or not. For text strings the limit is 64 bytes for the UTF8 +-- representation of the text string. For byte strings the limit is 64 bytes +-- for the raw byte form (ie not the input hex, but after hex decoding). +-- +-- In the \"detailed schema\" mapping, the idea is that we expose the full +-- representation capability of the script data in the form of a JSON schema. +-- This means the full representation is available and can be controlled +-- precisely. It also means any script data can be converted into the JSON and +-- back without loss. That is we can round-trip the script data via the JSON and +-- also round-trip schema-compliant JSON via script data. +-- +data ScriptDataJsonSchema = + + -- | Use the \"no schema\" mapping between JSON and script data as + -- described above. + ScriptDataJsonNoSchema + + -- | Use the \"detailed schema\" mapping between JSON and script data as + -- described above. + | ScriptDataJsonDetailedSchema + deriving (Eq, Show) + + +-- | Convert a value from JSON into script data, using the given choice of +-- mapping between JSON and script data. +-- +-- This may fail with a conversion error if the JSON is outside the supported +-- subset for the chosen mapping. See 'ScriptDataJsonSchema' for the details. +-- +scriptDataFromJson :: ScriptDataJsonSchema + -> Aeson.Value + -> Either ScriptDataJsonError ScriptData +scriptDataFromJson schema v = do + d <- first (ScriptDataJsonSchemaError v) (scriptDataFromJson' v) + first (ScriptDataRangeError v) (validateScriptData d) + return d + where + scriptDataFromJson' = + case schema of + ScriptDataJsonNoSchema -> scriptDataFromJsonNoSchema + ScriptDataJsonDetailedSchema -> scriptDataFromJsonDetailedSchema + + + +-- | Convert a script data value into JSON , using the given choice of mapping +-- between JSON and script data. +-- +-- This conversion is total but is not necessarily invertible. +-- See 'ScriptDataJsonSchema' for the details. +-- +scriptDataToJson :: ScriptDataJsonSchema + -> ScriptData + -> Aeson.Value +scriptDataToJson schema = + case schema of + ScriptDataJsonNoSchema -> scriptDataToJsonNoSchema + ScriptDataJsonDetailedSchema -> scriptDataToJsonDetailedSchema + + +-- ---------------------------------------------------------------------------- +-- JSON conversion using the the "no schema" style +-- + +scriptDataToJsonNoSchema :: ScriptData -> Aeson.Value +scriptDataToJsonNoSchema = conv + where + conv :: ScriptData -> Aeson.Value + conv (ScriptDataNumber n) = Aeson.Number (fromInteger n) + conv (ScriptDataBytes bs) + | Right s <- Text.decodeUtf8' bs + , Text.all Char.isPrint s + = Aeson.String s + + | otherwise + = Aeson.String (bytesPrefix <> Text.decodeLatin1 (Base16.encode bs)) + + conv (ScriptDataList vs) = Aeson.Array (Vector.fromList (map conv vs)) + conv (ScriptDataMap kvs) = Aeson.object + [ (convKey k, conv v) + | (k, v) <- kvs ] + + conv (ScriptDataConstructor n vs) = + Aeson.Array $ + Vector.fromList + [ Aeson.Number (fromInteger n) + , Aeson.Array (Vector.fromList (map conv vs)) + ] + + + -- Script data allows any value as a key, not just string as JSON does. + -- For simple types we just convert them to string dirctly. + -- For structured keys we render them as JSON and use that as the string. + convKey :: ScriptData -> Text + convKey (ScriptDataNumber n) = Text.pack (show n) + convKey (ScriptDataBytes bs) = bytesPrefix + <> Text.decodeLatin1 (Base16.encode bs) + convKey v = Text.Lazy.toStrict + . Aeson.Text.encodeToLazyText + . conv + $ v + +scriptDataFromJsonNoSchema :: Aeson.Value + -> Either ScriptDataJsonSchemaError + ScriptData +scriptDataFromJsonNoSchema = conv + where + conv :: Aeson.Value + -> Either ScriptDataJsonSchemaError ScriptData + conv Aeson.Null = Left ScriptDataJsonNullNotAllowed + conv Aeson.Bool{} = Left ScriptDataJsonBoolNotAllowed + + conv (Aeson.Number d) = + case Scientific.floatingOrInteger d :: Either Double Integer of + Left n -> Left (ScriptDataJsonNumberNotInteger n) + Right n -> Right (ScriptDataNumber n) + + conv (Aeson.String s) + | Just s' <- Text.stripPrefix bytesPrefix s + , let bs' = Text.encodeUtf8 s' + , Right bs <- Base16.decode bs' + , not (BSC.any (\c -> c >= 'A' && c <= 'F') bs') + = Right (ScriptDataBytes bs) + + | otherwise + = Right (ScriptDataBytes (Text.encodeUtf8 s)) + + conv (Aeson.Array vs) = + fmap ScriptDataList + . traverse conv + $ Vector.toList vs + + conv (Aeson.Object kvs) = + fmap ScriptDataMap + . traverse (\(k,v) -> (,) (convKey k) <$> conv v) + . List.sortOn fst + $ HashMap.toList kvs + + convKey :: Text -> ScriptData + convKey s = + fromMaybe (ScriptDataBytes (Text.encodeUtf8 s)) $ + parseAll ((fmap ScriptDataNumber pSigned <* Atto.endOfInput) + <|> (fmap ScriptDataBytes pBytes <* Atto.endOfInput)) s + +-- | JSON strings that are base16 encoded and prefixed with 'bytesPrefix' will +-- be encoded as CBOR bytestrings. +bytesPrefix :: Text +bytesPrefix = "0x" + + +-- ---------------------------------------------------------------------------- +-- JSON conversion using the "detailed schema" style +-- + +scriptDataToJsonDetailedSchema :: ScriptData -> Aeson.Value +scriptDataToJsonDetailedSchema = conv + where + conv :: ScriptData -> Aeson.Value + conv (ScriptDataNumber n) = singleFieldObject "int" + . Aeson.Number + $ fromInteger n + conv (ScriptDataBytes bs) = singleFieldObject "bytes" + . Aeson.String + $ Text.decodeLatin1 (Base16.encode bs) + conv (ScriptDataList vs) = singleFieldObject "list" + . Aeson.Array + $ Vector.fromList (map conv vs) + conv (ScriptDataMap kvs) = singleFieldObject "map" + . Aeson.Array + $ Vector.fromList + [ Aeson.object [ ("k", conv k), ("v", conv v) ] + | (k, v) <- kvs ] + + conv (ScriptDataConstructor n vs) = + Aeson.object + [ ("constructor", Aeson.Number (fromInteger n)) + , ("fields", Aeson.Array (Vector.fromList (map conv vs))) + ] + + singleFieldObject name v = Aeson.object [(name, v)] + + +scriptDataFromJsonDetailedSchema :: Aeson.Value + -> Either ScriptDataJsonSchemaError + ScriptData +scriptDataFromJsonDetailedSchema = conv + where + conv :: Aeson.Value + -> Either ScriptDataJsonSchemaError ScriptData + conv (Aeson.Object m) = + case HashMap.toList m of + [("int", Aeson.Number d)] -> + case Scientific.floatingOrInteger d :: Either Double Integer of + Left n -> Left (ScriptDataJsonNumberNotInteger n) + Right n -> Right (ScriptDataNumber n) + + [("bytes", Aeson.String s)] + | Right bs <- Base16.decode (Text.encodeUtf8 s) + -> Right (ScriptDataBytes bs) + + [("list", Aeson.Array vs)] -> + fmap ScriptDataList + . traverse conv + $ Vector.toList vs + + [("map", Aeson.Array kvs)] -> + fmap ScriptDataMap + . traverse convKeyValuePair + $ Vector.toList kvs + + [("constructor", Aeson.Number d), + ("fields", Aeson.Array vs)] -> + case Scientific.floatingOrInteger d :: Either Double Integer of + Left n -> Left (ScriptDataJsonNumberNotInteger n) + Right n -> fmap (ScriptDataConstructor n) + . traverse conv + $ Vector.toList vs + + (key, v):_ | key `elem` ["int", "bytes", "list", "map", "constructor"] -> + Left (ScriptDataJsonTypeMismatch key v) + + kvs -> Left (ScriptDataJsonBadObject kvs) + + conv v = Left (ScriptDataJsonNotObject v) + + convKeyValuePair :: Aeson.Value + -> Either ScriptDataJsonSchemaError + (ScriptData, ScriptData) + convKeyValuePair (Aeson.Object m) + | HashMap.size m == 2 + , Just k <- m HashMap.!? "k" + , Just v <- m HashMap.!? "v" + = (,) <$> conv k <*> conv v + + convKeyValuePair v = Left (ScriptDataJsonBadMapPair v) + + +-- ---------------------------------------------------------------------------- +-- Shared JSON conversion error types +-- + +data ScriptDataJsonError = + ScriptDataJsonSchemaError !Aeson.Value !ScriptDataJsonSchemaError + | ScriptDataRangeError !Aeson.Value !ScriptDataRangeError + deriving (Eq, Show) + +data ScriptDataJsonSchemaError = + -- Only used for 'ScriptDataJsonNoSchema' + ScriptDataJsonNullNotAllowed + | ScriptDataJsonBoolNotAllowed + + -- Used by both mappings + | ScriptDataJsonNumberNotInteger !Double + + -- Only used for 'ScriptDataJsonDetailedSchema' + | ScriptDataJsonNotObject !Aeson.Value + | ScriptDataJsonBadObject ![(Text, Aeson.Value)] + | ScriptDataJsonBadMapPair !Aeson.Value + | ScriptDataJsonTypeMismatch !Text !Aeson.Value + deriving (Eq, Show) + +instance Error ScriptDataJsonError where + displayError (ScriptDataJsonSchemaError v detail) = + "JSON schema error within the script data: " + ++ LBS.unpack (Aeson.encode v) ++ "\n" ++ displayError detail + displayError (ScriptDataRangeError v detail) = + "Value out of range within the script data: " + ++ LBS.unpack (Aeson.encode v) ++ "\n" ++ displayError detail + +instance Error ScriptDataJsonSchemaError where + displayError ScriptDataJsonNullNotAllowed = + "JSON null values are not supported." + displayError ScriptDataJsonBoolNotAllowed = + "JSON bool values are not supported." + displayError (ScriptDataJsonNumberNotInteger d) = + "JSON numbers must be integers. Unexpected value: " ++ show d + displayError (ScriptDataJsonNotObject v) = + "JSON object expected. Unexpected value: " + ++ LBS.unpack (Aeson.encode v) + displayError (ScriptDataJsonBadObject v) = + "JSON object does not match the schema.\nExpected a single field named " + ++ "\"int\", \"bytes\", \"string\", \"list\" or \"map\".\n" + ++ "Unexpected object field(s): " + ++ LBS.unpack (Aeson.encode (Aeson.object v)) + displayError (ScriptDataJsonBadMapPair v) = + "Expected a list of key/value pair { \"k\": ..., \"v\": ... } objects." + ++ "\nUnexpected value: " ++ LBS.unpack (Aeson.encode v) + displayError (ScriptDataJsonTypeMismatch k v) = + "The value in the field " ++ show k ++ " does not have the type " + ++ "required by the schema.\nUnexpected value: " + ++ LBS.unpack (Aeson.encode v) + diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index 97b95f4a98c..05ec191f31d 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -1028,7 +1028,8 @@ data TxMintValue build era where TxMintValue :: MultiAssetSupportedInEra era -> Value - -> BuildTxWith build (Map PolicyId (Witness WitCtxMint era)) + -> BuildTxWith build + (Map PolicyId (ScriptWitness WitCtxMint era)) -> TxMintValue build era deriving instance Eq (TxMintValue build era) @@ -1267,14 +1268,24 @@ serialiseShelleyBasedTxBody -> TxBodyScriptData era -> Maybe (Ledger.AuxiliaryData ledgerera) -> ByteString -serialiseShelleyBasedTxBody _era txbody txscripts redeemers txmetadata = +serialiseShelleyBasedTxBody _era txbody txscripts + TxBodyNoScriptData txmetadata = + -- Backwards compat for pre-Alonzo era tx body files + CBOR.serializeEncoding' $ + CBOR.encodeListLen 3 + <> CBOR.toCBOR txbody + <> CBOR.toCBOR txscripts + <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + +serialiseShelleyBasedTxBody _era txbody txscripts + (TxBodyScriptData _ datums redeemers) + txmetadata = CBOR.serializeEncoding' $ CBOR.encodeListLen 5 <> CBOR.toCBOR txbody <> CBOR.toCBOR txscripts - <> (case redeemers of - TxBodyNoScriptData -> CBOR.encodeNull <> CBOR.encodeNull - TxBodyScriptData _ ds rs -> CBOR.toCBOR ds <> CBOR.toCBOR rs) + <> CBOR.toCBOR datums + <> CBOR.toCBOR redeemers <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata deserialiseShelleyBasedTxBody @@ -1340,6 +1351,7 @@ instance IsCardanoEra era => HasTextEnvelope (TxBody era) where data TxBodyError era = TxBodyEmptyTxIns + | TxBodyEmptyTxInsCollateral | TxBodyEmptyTxOuts | TxBodyOutputNegative Quantity (TxOut era) | TxBodyOutputOverflow Quantity (TxOut era) @@ -1352,6 +1364,8 @@ data TxBodyError era = instance Error (TxBodyError era) where displayError TxBodyEmptyTxIns = "Transaction body has no inputs" + displayError TxBodyEmptyTxInsCollateral = + "Transaction body has no collateral inputs, but uses Plutus scripts" displayError TxBodyEmptyTxOuts = "Transaction body has no outputs" displayError (TxBodyOutputNegative (Quantity q) txout) = "Negative quantity (" ++ show q ++ ") in transaction output: " ++ @@ -2075,10 +2089,14 @@ makeShelleyTransactionBody era@ShelleyBasedEraAlonzo case txMintValue of TxMintNone -> return () TxMintValue _ v _ -> guard (selectLovelace v == 0) ?! TxBodyMintAdaError + case txInsCollateral of + TxInsCollateralNone | not (Set.null languages) + -> Left TxBodyEmptyTxInsCollateral + _ -> return () case txProtocolParams of - BuildTxWith Just{} -> return () - BuildTxWith Nothing -> guard (not (Set.null languages)) - ?! TxBodyMissingProtocolParams + BuildTxWith Nothing | not (Set.null languages) + -> Left TxBodyMissingProtocolParams + _ -> return () return $ ShelleyTxBody era @@ -2257,7 +2275,7 @@ collectTxBodyScriptWitnesses TxBodyContent { -- The minting policies are indexed in policy id order in the value | let ValueNestedRep bundle = valueToNestedRep value , (ix, ValueNestedBundle policyid _) <- zip [0..] bundle - , ScriptWitness _ witness <- maybeToList (Map.lookup policyid witnesses) + , witness <- maybeToList (Map.lookup policyid witnesses) ] diff --git a/cardano-api/src/Cardano/Api/TxMetadata.hs b/cardano-api/src/Cardano/Api/TxMetadata.hs index ca9182d0d87..3086bfc4402 100644 --- a/cardano-api/src/Cardano/Api/TxMetadata.hs +++ b/cardano-api/src/Cardano/Api/TxMetadata.hs @@ -27,6 +27,12 @@ module Cardano.Api.TxMetadata ( toShelleyMetadata, fromShelleyMetadata, + -- * Shared parsing utils + parseAll, + pUnsigned, + pSigned, + pBytes, + -- * Data family instances AsType(..) ) where diff --git a/cardano-api/src/Cardano/Api/Value.hs b/cardano-api/src/Cardano/Api/Value.hs index 99f795eafe1..98d4bf520c1 100644 --- a/cardano-api/src/Cardano/Api/Value.hs +++ b/cardano-api/src/Cardano/Api/Value.hs @@ -13,6 +13,7 @@ module Cardano.Api.Value -- * Multi-asset values , Quantity(..) , PolicyId(..) + , scriptPolicyId , AssetName(..) , AssetId(..) , Value @@ -145,6 +146,10 @@ instance SerialiseAsRawBytes PolicyId where deserialiseFromRawBytes AsPolicyId bs = PolicyId <$> deserialiseFromRawBytes AsScriptHash bs +scriptPolicyId :: Script lang -> PolicyId +scriptPolicyId = PolicyId . hashScript + + newtype AssetName = AssetName ByteString deriving stock (Eq, Ord) deriving newtype (Show) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index beadd84d607..c5e8471359a 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs @@ -162,10 +162,12 @@ renderKeyCmd cmd = data TransactionCmd = TxBuildRaw AnyCardanoEra - [(TxIn, Maybe ScriptFile)] + [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] -- ^ Transaction inputs with optional spending scripts + [TxIn] + -- ^ Transaction inputs for collateral, only key witnesses, no scripts. [TxOutAnyEra] - (Maybe (Value, [ScriptFile])) + (Maybe (Value, [ScriptWitnessFiles WitCtxMint])) -- ^ Multi-Asset value with script witness (Maybe SlotNo) -- ^ Transaction lower bound @@ -173,13 +175,14 @@ data TransactionCmd -- ^ Transaction upper bound (Maybe Lovelace) -- ^ Tx fee - [(CertificateFile, Maybe ScriptFile)] + [(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] -- ^ Certificates with potential script witness - [(StakeAddress, Lovelace, Maybe ScriptFile)] + [(StakeAddress, Lovelace, Maybe (ScriptWitnessFiles WitCtxStake))] TxMetadataJsonSchema [ScriptFile] -- ^ Auxillary scripts [MetadataFile] + (Maybe ProtocolParamsSourceSpec) (Maybe UpdateProposalFile) TxBodyFile | TxSign TxBodyFile [WitnessSigningData] (Maybe NetworkId) TxFile diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index db648ecae2c..1fe9e3e84a8 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Shelley.Parsers @@ -44,6 +45,7 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import qualified Data.Aeson.Parser as Aeson.Parser import qualified Data.Attoparsec.ByteString.Char8 as Atto import qualified Options.Applicative as Opt import qualified Text.Parsec as Parsec @@ -211,6 +213,71 @@ pScriptFor name help = ScriptFile <$> Opt.strOption <> Opt.completer (Opt.bashCompleter "file") ) +pScriptWitnessFiles :: forall witctx. + WitCtx witctx + -> String + -> String + -> Parser (ScriptWitnessFiles witctx) +pScriptWitnessFiles witctx scriptFlagPrefix help = + toScriptWitnessFiles + <$> pScriptFor (scriptFlagPrefix ++ "-script-file") + ("The file containing the script to witness " ++ help) + <*> optional ((,,) <$> pScriptDatumOrFile + <*> pScriptRedeemerOrFile + <*> pExecutionUnits) + where + toScriptWitnessFiles :: ScriptFile + -> Maybe (ScriptDatumOrFile witctx, + ScriptRedeemerOrFile, + ExecutionUnits) + -> ScriptWitnessFiles witctx + toScriptWitnessFiles sf Nothing = SimpleScriptWitnessFile sf + toScriptWitnessFiles sf (Just (d,r,e)) = PlutusScriptWitnessFiles sf d r e + + pScriptDatumOrFile :: Parser (ScriptDatumOrFile witctx) + pScriptDatumOrFile = + case witctx of + WitCtxTxIn -> ScriptDatumOrFileForTxIn <$> pScriptDataOrFile "datum" + WitCtxMint -> pure NoScriptDatumOrFileForMint + WitCtxStake -> pure NoScriptDatumOrFileForStake + + pScriptRedeemerOrFile :: Parser ScriptDataOrFile + pScriptRedeemerOrFile = pScriptDataOrFile "redeemer" + + pScriptDataOrFile :: String -> Parser ScriptDataOrFile + pScriptDataOrFile dataFlagPrefix = + ScriptDataFile <$> pScriptDataFile dataFlagPrefix + <|> ScriptDataValue <$> pScriptDataValue dataFlagPrefix + + pScriptDataFile dataFlagPrefix = + Opt.strOption + ( Opt.long (dataFlagPrefix ++ "-file") + <> Opt.metavar "FILE" + <> Opt.help ("The file containing the script input " + ++ dataFlagPrefix ++ ".") + ) + + pScriptDataValue dataFlagPrefix = + Opt.option readerScriptData + ( Opt.long (dataFlagPrefix ++ "-value") + <> Opt.metavar "JSON" + <> Opt.help ("The value for the script input " ++ dataFlagPrefix ++ ".") + ) + + readerScriptData = do + v <- readerFromAttoParser Aeson.Parser.json + case scriptDataFromJson ScriptDataJsonNoSchema v of + Left err -> fail (displayError err) + Right sd -> return sd + + pExecutionUnits = + uncurry ExecutionUnits <$> + Opt.option Opt.auto + ( Opt.long "execution-units" + <> Opt.metavar "(INT, INT)" + <> Opt.help "The time and space units needed by the script." + ) + pStakeAddressCmd :: Parser StakeAddressCmd pStakeAddressCmd = asum @@ -507,6 +574,7 @@ pTransaction = pTransactionBuild :: Parser TransactionCmd pTransactionBuild = TxBuildRaw <$> pCardanoEra <*> some pTxIn + <*> many pTxInCollateral <*> many pTxOut <*> optional pMintMultiAsset <*> optional pInvalidBefore @@ -515,8 +583,11 @@ pTransaction = <*> many pCertificateFile <*> many pWithdrawal <*> pTxMetadataJsonSchema - <*> many (pScriptFor "auxiliary-script-file" "Filepath of auxiliary script(s)") + <*> many (pScriptFor + "auxiliary-script-file" + "Filepath of auxiliary script(s)") <*> many pMetadataFile + <*> optional pProtocolParamsSourceSpec <*> optional pUpdateProposalFile <*> pTxBodyFile Output @@ -1079,7 +1150,8 @@ pProtocolParamsFile = <> Opt.completer (Opt.bashCompleter "file") ) -pCertificateFile :: Parser (CertificateFile, Maybe ScriptFile) +pCertificateFile :: Parser (CertificateFile, + Maybe (ScriptWitnessFiles WitCtxStake)) pCertificateFile = (,) <$> (CertificateFile <$> ( Opt.strOption @@ -1092,7 +1164,10 @@ pCertificateFile = Opt.strOption (Opt.long "certificate" <> Opt.internal) ) ) - <*> optional (pScriptFor "certificate-script-file" "Filepath of the certificate script witness") + <*> optional (pScriptWitnessFiles + WitCtxStake + "certificate" + "the use of the certificate.") where helpText = "Filepath of the certificate. This encompasses all \ \types of certificates (stake pool certificates, \ @@ -1153,7 +1228,9 @@ pMetadataFile = <> Opt.completer (Opt.bashCompleter "file") ) -pWithdrawal :: Parser (StakeAddress, Lovelace, Maybe ScriptFile) +pWithdrawal :: Parser (StakeAddress, + Lovelace, + Maybe (ScriptWitnessFiles WitCtxStake)) pWithdrawal = (\(stakeAddr,lovelace) maybeScriptFp -> (stakeAddr, lovelace, maybeScriptFp)) <$> Opt.option (readerFromAttoParser parseWithdrawal) @@ -1161,7 +1238,10 @@ pWithdrawal = <> Opt.metavar "WITHDRAWAL" <> Opt.help helpText ) - <*> optional (pScriptFor "withdrawal-script-file" "Filepath of the withdrawal script witness.") + <*> optional (pScriptWitnessFiles + WitCtxStake + "withdrawal" + "the withdrawal of rewards.") where helpText = "The reward withdrawal as StakeAddress+Lovelace where \ \StakeAddress is the Bech32-encoded stake address \ @@ -1606,14 +1686,25 @@ pCardanoEra = asum , pure (AnyCardanoEra MaryEra) ] -pTxIn :: Parser (TxIn, Maybe ScriptFile) +pTxIn :: Parser (TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn)) pTxIn = (,) <$> Opt.option (readerFromAttoParser parseTxIn) ( Opt.long "tx-in" <> Opt.metavar "TX-IN" <> Opt.help "TxId#TxIx" ) - <*> optional (pScriptFor "txin-script-file" "Filepath of the spending script witness") + <*> optional (pScriptWitnessFiles + WitCtxTxIn + "txin" + "the spending of the transaction input.") + +pTxInCollateral :: Parser TxIn +pTxInCollateral = + Opt.option (readerFromAttoParser parseTxIn) + ( Opt.long "tx-in-collateral" + <> Opt.metavar "TX-IN" + <> Opt.help "TxId#TxIx" + ) parseTxIn :: Atto.Parser TxIn parseTxIn = TxIn <$> parseTxId <*> (Atto.char '#' *> parseTxIx) @@ -1657,7 +1748,7 @@ pMultiAsset = <> Opt.help "Multi-asset value(s) with the multi-asset cli syntax" ) -pMintMultiAsset :: Parser (Value, [ScriptFile]) +pMintMultiAsset :: Parser (Value, [ScriptWitnessFiles WitCtxMint]) pMintMultiAsset = (,) <$> Opt.option (readerFromParsecParser parseValue) @@ -1665,7 +1756,10 @@ pMintMultiAsset = <> Opt.metavar "VALUE" <> Opt.help helpText ) - <*> some (pScriptFor "minting-script-file" "Filepath of the multi-asset witness script.") + <*> some (pScriptWitnessFiles + WitCtxMint + "minting" + "the minting of assets for a particular policy Id.") where helpText = "Mint multi-asset value(s) with the multi-asset cli syntax. \ diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index 08ca2252c3e..0442290b379 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -19,6 +19,7 @@ import qualified Data.Aeson as Aeson import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import qualified Data.Text as Text import Data.Type.Equality (TestEquality (..)) @@ -69,6 +70,9 @@ data ShelleyTxCmdError | ShelleyTxCmdMetadataJsonParseError !FilePath !String | ShelleyTxCmdMetadataConversionError !FilePath !TxMetadataJsonError | ShelleyTxCmdMetaValidationError !FilePath ![(Word64, TxMetadataRangeError)] + | ShelleyTxCmdScriptDataJsonParseError FilePath String + | ShelleyTxCmdScriptDataConversionError FilePath ScriptDataJsonError + | ShelleyTxCmdScriptDataValidationError FilePath ScriptDataRangeError | ShelleyTxCmdMetaDecodeError !FilePath !CBOR.DecoderError | ShelleyTxCmdBootstrapWitnessError !ShelleyBootstrapWitnessError | ShelleyTxCmdSocketEnvError !EnvSocketError @@ -83,8 +87,11 @@ data ShelleyTxCmdError | ShelleyTxCmdNotImplemented Text | ShelleyTxCmdWitnessEraMismatch AnyCardanoEra AnyCardanoEra WitnessFile | ShelleyTxCmdScriptLanguageNotSupportedInEra AnyScriptLanguage AnyCardanoEra + | ShelleyTxCmdScriptExpectedSimple FilePath AnyScriptLanguage + | ShelleyTxCmdScriptExpectedPlutus FilePath AnyScriptLanguage | ShelleyTxCmdGenesisCmdError !ShelleyGenesisCmdError - | ShelleyTxCmdPolicyIdNotSpecified PolicyId + | ShelleyTxCmdPolicyIdsMissing [PolicyId] + | ShelleyTxCmdPolicyIdsExcess [PolicyId] deriving Show data SomeTxBodyError where @@ -115,6 +122,17 @@ renderShelleyTxCmdError err = Text.intercalate "\n" [ "key " <> show k <> ":" <> Text.pack (displayError valErr) | (k, valErr) <- errs ] + + ShelleyTxCmdScriptDataJsonParseError fp jsonErr -> + "Invalid JSON format in file: " <> show fp <> + "\nJSON parse error: " <> Text.pack jsonErr + ShelleyTxCmdScriptDataConversionError fp cerr -> + "Error reading metadata at: " <> show fp + <> "\n" <> Text.pack (displayError cerr) + ShelleyTxCmdScriptDataValidationError fp verr -> + "Error validating script data at: " <> show fp <> ":\n" <> + Text.pack (displayError verr) + ShelleyTxCmdSocketEnvError envSockErr -> renderEnvSocketError envSockErr ShelleyTxCmdAesonDecodeProtocolParamsError fp decErr -> "Error while decoding the protocol parameters at: " <> show fp @@ -161,14 +179,31 @@ renderShelleyTxCmdError err = ShelleyTxCmdScriptLanguageNotSupportedInEra (AnyScriptLanguage lang) era -> "The script language " <> show lang <> " is not supported in the " <> renderEra era <> " era." + + ShelleyTxCmdScriptExpectedSimple file (AnyScriptLanguage lang) -> + Text.pack file <> ": expected a script in the simple script language, " <> + "but it is actually using " <> show lang <> ". Alternatively, to use " <> + "a Plutus script, you must also specify the redeemer " <> + "(datum if appropriate) and script execution units." + + ShelleyTxCmdScriptExpectedPlutus file (AnyScriptLanguage lang) -> + Text.pack file <> ": expected a script in the Plutus script language, " <> + "but it is actually using " <> show lang <> "." + ShelleyTxCmdEraConsensusModeMismatch fp mode era -> "Submitting " <> renderEra era <> " era transaction (" <> show fp <> ") is not supported in the " <> renderMode mode <> " consensus mode." ShelleyTxCmdGenesisCmdError e -> renderShelleyGenesisCmdError e - ShelleyTxCmdPolicyIdNotSpecified sWit -> - "A script provided to witness minting does not correspond to the policy id \ - \of any asset specified in the \"--mint\" field. The script hash is: " - <> serialiseToRawBytesHexText sWit + ShelleyTxCmdPolicyIdsMissing policyids -> + "The \"--mint\" flag specifies an asset with a policy Id, but no \ + \corresponding monetary policy script has been provided as a witness \ + \(via the \"--minting-script-file\" flag). The policy Id in question is: " + <> Text.intercalate ", " (map serialiseToRawBytesHexText policyids) + + ShelleyTxCmdPolicyIdsExcess policyids -> + "A script provided to witness minting does not correspond to the policy \ + \id of any asset specified in the \"--mint\" field. The script hash is: " + <> Text.intercalate ", " (map serialiseToRawBytesHexText policyids) renderEra :: AnyCardanoEra -> Text renderEra (AnyCardanoEra ByronEra) = "Byron" @@ -193,16 +228,17 @@ renderFeature TxFeatureMultiAssetOutputs = "Multi-Asset outputs" renderFeature TxFeatureScriptWitnesses = "Script witnesses" renderFeature TxFeatureShelleyKeys = "Shelley keys" renderFeature TxFeatureCollateral = "Collateral inputs" +renderFeature TxFeatureProtocolParameters = "Protocol parameters" runTransactionCmd :: TransactionCmd -> ExceptT ShelleyTxCmdError IO () runTransactionCmd cmd = case cmd of - TxBuildRaw era txins txouts mValue mLowBound mUpperBound + TxBuildRaw era txins txinsc txouts mValue mLowBound mUpperBound fee certs wdrls metadataSchema scriptFiles - metadataFiles mUpProp out -> - runTxBuildRaw era txins txouts mLowBound mUpperBound + metadataFiles mpparams mUpProp out -> + runTxBuildRaw era txins txinsc txouts mLowBound mUpperBound fee mValue certs wdrls metadataSchema - scriptFiles metadataFiles mUpProp out + scriptFiles metadataFiles mpparams mUpProp out TxSign txinfile skfiles network txoutfile -> runTxSign txinfile skfiles network txoutfile TxSubmit anyConensusModeParams network txFp -> @@ -226,8 +262,10 @@ runTransactionCmd cmd = runTxBuildRaw :: AnyCardanoEra - -> [(TxIn, Maybe ScriptFile)] + -> [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] -- ^ TxIn with potential script witness + -> [TxIn] + -- ^ TxIn for collateral -> [TxOutAnyEra] -> Maybe SlotNo -- ^ Tx lower bound @@ -235,27 +273,31 @@ runTxBuildRaw -- ^ Tx upper bound -> Maybe Lovelace -- ^ Tx fee - -> Maybe (Value, [ScriptFile]) + -> Maybe (Value, [ScriptWitnessFiles WitCtxMint]) -- ^ Multi-Asset value(s) - -> [(CertificateFile, Maybe ScriptFile)] + -> [(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] -- ^ Certificate with potential script witness - -> [(StakeAddress, Lovelace, Maybe ScriptFile)] + -> [(StakeAddress, Lovelace, Maybe (ScriptWitnessFiles WitCtxStake))] -> TxMetadataJsonSchema -> [ScriptFile] -> [MetadataFile] + -> Maybe ProtocolParamsSourceSpec -> Maybe UpdateProposalFile -> TxBodyFile -> ExceptT ShelleyTxCmdError IO () -runTxBuildRaw (AnyCardanoEra era) inputsAndScripts txouts mLowerBound - mUpperBound mFee mValue +runTxBuildRaw (AnyCardanoEra era) + inputsAndScripts inputsCollateral txouts + mLowerBound mUpperBound + mFee mValue certFiles withdrawals metadataSchema scriptFiles - metadataFiles mUpdatePropFile + metadataFiles mpparams mUpdatePropFile (TxBodyFile fpath) = do txBodyContent <- TxBodyContent <$> validateTxIns era inputsAndScripts - <*> pure TxInsCollateralNone --TODO alonzo: support this + <*> validateTxInsCollateral + era inputsCollateral <*> validateTxOuts era txouts <*> validateTxFee era mFee <*> ((,) <$> validateTxValidityLowerBound era mLowerBound @@ -264,7 +306,7 @@ runTxBuildRaw (AnyCardanoEra era) inputsAndScripts txouts mLowerBound <*> validateTxAuxScripts era scriptFiles <*> pure TxAuxScriptDataNone --TODO alonzo: support this <*> pure TxExtraKeyWitnessesNone --TODO alonzo: support this - <*> pure (BuildTxWith Nothing) --TODO alonzo: support this + <*> validateProtocolParameters era mpparams <*> validateTxWithdrawals era withdrawals <*> validateTxCertificates era certFiles <*> validateTxUpdateProposal era mUpdatePropFile @@ -299,6 +341,7 @@ data TxFeature = TxFeatureShelleyAddresses | TxFeatureScriptWitnesses | TxFeatureShelleyKeys | TxFeatureCollateral + | TxFeatureProtocolParameters deriving Show txFeatureMismatch :: CardanoEra era @@ -308,24 +351,37 @@ txFeatureMismatch era feature = left (ShelleyTxCmdTxFeatureMismatch (anyCardanoEra era) feature) validateTxIns - :: forall era. IsCardanoEra era - => CardanoEra era - -> [(TxIn, Maybe ScriptFile)] - -> ExceptT ShelleyTxCmdError IO [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] + :: forall era. + CardanoEra era + -> [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] + -> ExceptT ShelleyTxCmdError IO + [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] validateTxIns era = mapM convert where convert - :: (TxIn, Maybe ScriptFile) - -> ExceptT ShelleyTxCmdError IO (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)) - convert (txin, mScriptFile) = - case mScriptFile of - Just sFp -> do - sWit <- createScriptWitness era sFp + :: (TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn)) + -> ExceptT ShelleyTxCmdError IO + (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)) + convert (txin, mScriptWitnessFiles) = + case mScriptWitnessFiles of + Just scriptWitnessFiles -> do + sWit <- createScriptWitness era scriptWitnessFiles return ( txin , BuildTxWith $ ScriptWitness ScriptWitnessForSpending sWit ) Nothing -> return (txin, BuildTxWith $ KeyWitness KeyWitnessForSpending) + +validateTxInsCollateral :: CardanoEra era + -> [TxIn] + -> ExceptT ShelleyTxCmdError IO (TxInsCollateral era) +validateTxInsCollateral _ [] = return TxInsCollateralNone +validateTxInsCollateral era txins = + case collateralSupportedInEra era of + Nothing -> txFeatureMismatch era TxFeatureCollateral + Just supported -> return (TxInsCollateral supported txins) + + validateTxOuts :: forall era. CardanoEra era -> [TxOutAnyEra] @@ -435,9 +491,9 @@ validateTxAuxScripts era files = panic "TODO alonzo: validateTxAuxScripts AuxScriptsInAlonzoEra" validateTxWithdrawals - :: forall era. IsCardanoEra era - => CardanoEra era - -> [(StakeAddress, Lovelace, Maybe ScriptFile)] + :: forall era. + CardanoEra era + -> [(StakeAddress, Lovelace, Maybe (ScriptWitnessFiles WitCtxStake))] -> ExceptT ShelleyTxCmdError IO (TxWithdrawals BuildTx era) validateTxWithdrawals _ [] = return TxWithdrawalsNone validateTxWithdrawals era withdrawals = @@ -448,13 +504,15 @@ validateTxWithdrawals era withdrawals = return (TxWithdrawals supported convWithdrawals) where convert - :: (StakeAddress, Lovelace, Maybe ScriptFile) + :: (StakeAddress, Lovelace, Maybe (ScriptWitnessFiles WitCtxStake)) -> ExceptT ShelleyTxCmdError IO - (StakeAddress, Lovelace, BuildTxWith BuildTx (Witness WitCtxStake era)) - convert (sAddr, ll, mScriptFile) = - case mScriptFile of - Just sFp -> do - sWit <- createScriptWitness era sFp + (StakeAddress, + Lovelace, + BuildTxWith BuildTx (Witness WitCtxStake era)) + convert (sAddr, ll, mScriptWitnessFiles) = + case mScriptWitnessFiles of + Just scriptWitnessFiles -> do + sWit <- createScriptWitness era scriptWitnessFiles return ( sAddr , ll , BuildTxWith $ ScriptWitness ScriptWitnessForStakeAddr sWit @@ -462,9 +520,9 @@ validateTxWithdrawals era withdrawals = Nothing -> return (sAddr,ll, BuildTxWith $ KeyWitness KeyWitnessForStakeAddr) validateTxCertificates - :: forall era. IsCardanoEra era - => CardanoEra era - -> [(CertificateFile, Maybe ScriptFile)] + :: forall era. + CardanoEra era + -> [(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] -> ExceptT ShelleyTxCmdError IO (TxCertificates BuildTx era) validateTxCertificates era certFiles = case certificatesSupportedInEra era of @@ -494,22 +552,35 @@ validateTxCertificates era certFiles = _ -> return Nothing convert - :: (CertificateFile, Maybe ScriptFile) - -> ExceptT ShelleyTxCmdError IO (Maybe (StakeCredential, Witness WitCtxStake era)) - convert (cert, mScript) = do + :: (CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake)) + -> ExceptT ShelleyTxCmdError IO + (Maybe (StakeCredential, Witness WitCtxStake era)) + convert (cert, mScriptWitnessFiles) = do mStakeCred <- deriveStakeCredentialWitness cert case mStakeCred of Nothing -> return Nothing Just sCred -> - case mScript of - Just sFp -> do - sWit <- createScriptWitness era sFp + case mScriptWitnessFiles of + Just scriptWitnessFiles -> do + sWit <- createScriptWitness era scriptWitnessFiles return $ Just ( sCred , ScriptWitness ScriptWitnessForStakeAddr sWit ) Nothing -> return $ Just (sCred, KeyWitness KeyWitnessForStakeAddr) +validateProtocolParameters + :: CardanoEra era + -> Maybe ProtocolParamsSourceSpec + -> ExceptT ShelleyTxCmdError IO + (BuildTxWith BuildTx (Maybe ProtocolParameters)) +validateProtocolParameters _ Nothing = return (BuildTxWith Nothing) +validateProtocolParameters era (Just pparamsspec) = + case scriptDataSupportedInEra era of + Nothing -> txFeatureMismatch era TxFeatureProtocolParameters + Just _ -> BuildTxWith . Just <$> + readProtocolParametersSourceSpec pparamsspec + validateTxUpdateProposal :: CardanoEra era -> Maybe UpdateProposalFile -> ExceptT ShelleyTxCmdError IO (TxUpdateProposal era) @@ -523,79 +594,128 @@ validateTxUpdateProposal era (Just (UpdateProposalFile file)) = return (TxUpdateProposal supported prop) -validateTxMintValue :: forall era. IsCardanoEra era - => CardanoEra era - -> Maybe (Value, [ScriptFile]) +validateTxMintValue :: forall era. + CardanoEra era + -> Maybe (Value, [ScriptWitnessFiles WitCtxMint]) -> ExceptT ShelleyTxCmdError IO (TxMintValue BuildTx era) validateTxMintValue _ Nothing = return TxMintNone -validateTxMintValue era (Just (val, scripts)) = +validateTxMintValue era (Just (val, scriptWitnessFiles)) = case multiAssetSupportedInEra era of - Left _ -> txFeatureMismatch era TxFeatureMintValue - Right supported -> do - pidsAndWits <- pairAllPolIdsWithScripts val scripts - return (TxMintValue supported val - . BuildTxWith $ Map.fromList pidsAndWits - ) + Left _ -> txFeatureMismatch era TxFeatureMintValue + Right supported -> do + -- The set of policy ids for which we need witnesses: + let witnessesNeededSet :: Set PolicyId + witnessesNeededSet = + Set.fromList [ pid | (AssetId pid _, _) <- valueToList val ] + + -- The set (and map) of policy ids for which we have witnesses: + witnesses <- mapM (createScriptWitness era) scriptWitnessFiles + let witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era) + witnessesProvidedMap = Map.fromList + [ (scriptWitnessPolicyId witness, witness) + | witness <- witnesses ] + witnessesProvidedSet = Map.keysSet witnessesProvidedMap + + -- Check not too many, nor too few: + validateAllWitnessesProvided witnessesNeededSet witnessesProvidedSet + validateNoUnnecessaryWitnesses witnessesNeededSet witnessesProvidedSet + + return (TxMintValue supported val (BuildTxWith witnessesProvidedMap)) where - extractPolicyIds :: Value -> [PolicyId] - extractPolicyIds v = map (\(AssetId polId _, _) -> polId) (valueToList v) - - - pairAllPolIdsWithScripts - :: Value -> [ScriptFile] - -> ExceptT ShelleyTxCmdError IO [(PolicyId, Witness WitCtxMint era)] - pairAllPolIdsWithScripts vals sFiles = do - sInLangs <- sequence - [ firstExceptT ShelleyTxCmdScriptFileError $ - readFileScriptInAnyLang file - | ScriptFile file <- sFiles ] - let valPids = extractPolicyIds vals - mapM (pairPolIdWithScriptWit valPids) sInLangs - - -- Check that the script hash exists in the minted multi asset - pairPolIdWithScriptWit - :: [PolicyId] - -> ScriptInAnyLang - -> ExceptT ShelleyTxCmdError IO (PolicyId, Witness WitCtxMint era) - pairPolIdWithScriptWit valuePids (ScriptInAnyLang sLang script) = do - let scriptHash = PolicyId $ hashScript script - if scriptHash `elem` valuePids - then case scriptLanguageSupportedInEra era sLang of - Nothing -> left $ ShelleyTxCmdScriptLanguageNotSupportedInEra - (AnyScriptLanguage sLang) - (AnyCardanoEra era) - Just sLangInEra -> - case script of - SimpleScript sVer sScript -> - return ( scriptHash - , ScriptWitness ScriptWitnessForMinting - $ SimpleScriptWitness sLangInEra sVer sScript - ) - PlutusScript _ _ -> - panic "TODO alonzo: reateScriptWitness: Plutus scripts not supported yet." - - else left $ ShelleyTxCmdPolicyIdNotSpecified scriptHash + validateAllWitnessesProvided witnessesNeeded witnessesProvided + | null witnessesMissing = return () + | otherwise = left (ShelleyTxCmdPolicyIdsMissing witnessesMissing) + where + witnessesMissing = Set.elems (witnessesNeeded Set.\\ witnessesProvided) + + validateNoUnnecessaryWitnesses witnessesNeeded witnessesProvided + | null witnessesExtra = return () + | otherwise = left (ShelleyTxCmdPolicyIdsExcess witnessesExtra) + where + witnessesExtra = Set.elems (witnessesProvided Set.\\ witnessesNeeded) + +scriptWitnessPolicyId :: ScriptWitness witctx era -> PolicyId +scriptWitnessPolicyId witness = + case scriptWitnessScript witness of + ScriptInEra _ script -> scriptPolicyId script createScriptWitness - :: IsCardanoEra era - => CardanoEra era - -> ScriptFile + :: CardanoEra era + -> ScriptWitnessFiles witctx -> ExceptT ShelleyTxCmdError IO (ScriptWitness witctx era) -createScriptWitness era (ScriptFile fp) = do - ScriptInAnyLang sLang script <- firstExceptT ShelleyTxCmdScriptFileError - $ readFileScriptInAnyLang fp - case scriptLanguageSupportedInEra era sLang of - Just sLangInEra -> - case script of - SimpleScript sVer sScript -> - return $ SimpleScriptWitness sLangInEra sVer sScript - PlutusScript _ _ -> panic "TODO alonzo: createScriptWitness: Plutus scripts not supported yet." - - Nothing -> - left $ ShelleyTxCmdScriptLanguageNotSupportedInEra - (AnyScriptLanguage sLang) - (AnyCardanoEra era) +createScriptWitness era (SimpleScriptWitnessFile (ScriptFile scriptFile)) = do + script@(ScriptInAnyLang lang _) <- firstExceptT ShelleyTxCmdScriptFileError $ + readFileScriptInAnyLang scriptFile + ScriptInEra langInEra script' <- validateScriptSupportedInEra era script + case script' of + SimpleScript version sscript -> + return $ SimpleScriptWitness + langInEra version 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. + PlutusScript{} -> + left $ ShelleyTxCmdScriptExpectedSimple + scriptFile + (AnyScriptLanguage lang) + +createScriptWitness era (PlutusScriptWitnessFiles + (ScriptFile scriptFile) + datumOrFile + redeemerOrFile + execUnits) = do + script@(ScriptInAnyLang lang _) <- firstExceptT ShelleyTxCmdScriptFileError $ + readFileScriptInAnyLang scriptFile + ScriptInEra langInEra script' <- validateScriptSupportedInEra era script + case script' of + PlutusScript version pscript -> do + datum <- readScriptDatumOrFile datumOrFile + redeemer <- readScriptRedeemerOrFile redeemerOrFile + return $ PlutusScriptWitness + langInEra version pscript + datum + redeemer + execUnits + + -- If the supplied cli flags were for a plutus script (i.e. the user did + -- supply the datum, redeemer and ex units), but the script file turns + -- out to be a valid simple script, then we must fail. + SimpleScript{} -> + left $ ShelleyTxCmdScriptExpectedPlutus + scriptFile + (AnyScriptLanguage lang) + + +readScriptDatumOrFile :: ScriptDatumOrFile witctx + -> ExceptT ShelleyTxCmdError IO (ScriptDatum witctx) +readScriptDatumOrFile (ScriptDatumOrFileForTxIn df) = ScriptDatumForTxIn <$> + readScriptDataOrFile df +readScriptDatumOrFile NoScriptDatumOrFileForMint = pure NoScriptDatumForMint +readScriptDatumOrFile NoScriptDatumOrFileForStake = pure NoScriptDatumForStake + +readScriptRedeemerOrFile :: ScriptRedeemerOrFile + -> ExceptT ShelleyTxCmdError IO ScriptRedeemer +readScriptRedeemerOrFile = readScriptDataOrFile + +readScriptDataOrFile :: ScriptDataOrFile + -> ExceptT ShelleyTxCmdError IO ScriptData +readScriptDataOrFile (ScriptDataValue d) = return d +readScriptDataOrFile (ScriptDataFile fp) = do + bs <- handleIOExceptT (ShelleyTxCmdReadFileError . FileIOError fp) $ + LBS.readFile fp + v <- firstExceptT (ShelleyTxCmdScriptDataJsonParseError fp) $ + hoistEither $ + Aeson.eitherDecode' bs + sd <- firstExceptT (ShelleyTxCmdScriptDataConversionError fp) $ + hoistEither $ + scriptDataFromJson ScriptDataJsonDetailedSchema v + firstExceptT (ShelleyTxCmdScriptDataValidationError fp) $ + hoistEither $ + validateScriptData sd + return sd + -- ---------------------------------------------------------------------------- -- Transaction signing @@ -687,13 +807,7 @@ runTxCalculateMinFee (TxBodyFile txbodyFile) nw protocolParamsSourceSpec onlyInShelleyBasedEras "calculate-min-fee for Byron era transactions" =<< readFileTxBody txbodyFile - pparams <- - case protocolParamsSourceSpec of - ParamsFromGenesis (GenesisFile f) -> - fromShelleyPParams . sgProtocolParams <$> - firstExceptT ShelleyTxCmdGenesisCmdError - (readShelleyGenesis f identity) - ParamsFromFile f -> readProtocolParameters f + pparams <- readProtocolParametersSourceSpec protocolParamsSourceSpec let tx = makeSignedTransaction [] txbody Lovelace fee = estimateTransactionFee @@ -715,11 +829,7 @@ runTxCalculateMinValue -> Value -> ExceptT ShelleyTxCmdError IO () runTxCalculateMinValue protocolParamsSourceSpec value = do - pp <- case protocolParamsSourceSpec of - ParamsFromGenesis (GenesisFile f) -> - fromShelleyPParams . sgProtocolParams <$> - firstExceptT ShelleyTxCmdGenesisCmdError (readShelleyGenesis f identity) - ParamsFromFile f -> readProtocolParameters f + pp <- readProtocolParametersSourceSpec protocolParamsSourceSpec let minValues = case protocolParamMinUTxOValue pp of @@ -736,6 +846,16 @@ runTxCreatePolicyId (ScriptFile sFile) = do readFileScriptInAnyLang sFile liftIO . putTextLn . serialiseToRawBytesHexText $ hashScript script +readProtocolParametersSourceSpec :: ProtocolParamsSourceSpec + -> ExceptT ShelleyTxCmdError IO + ProtocolParameters +readProtocolParametersSourceSpec (ParamsFromGenesis (GenesisFile f)) = + fromShelleyPParams . sgProtocolParams <$> + firstExceptT ShelleyTxCmdGenesisCmdError + (readShelleyGenesis f identity) +readProtocolParametersSourceSpec (ParamsFromFile f) = + readProtocolParameters f + --TODO: eliminate this and get only the necessary params, and get them in a more -- helpful way rather than requiring them as a local file. readProtocolParameters :: ProtocolParamsFile @@ -1032,6 +1152,7 @@ readFileInAnyCardanoEra , HasTextEnvelope (thing ShelleyEra) , HasTextEnvelope (thing AllegraEra) , HasTextEnvelope (thing MaryEra) + , HasTextEnvelope (thing AlonzoEra) ) => (forall era. AsType era -> AsType (thing era)) -> FilePath @@ -1045,6 +1166,7 @@ readFileInAnyCardanoEra asThing file = , FromSomeType (asThing AsShelleyEra) (InAnyCardanoEra ShelleyEra) , FromSomeType (asThing AsAllegraEra) (InAnyCardanoEra AllegraEra) , FromSomeType (asThing AsMaryEra) (InAnyCardanoEra MaryEra) + , FromSomeType (asThing AsAlonzoEra) (InAnyCardanoEra AlonzoEra) ] file diff --git a/cardano-cli/src/Cardano/CLI/Types.hs b/cardano-cli/src/Cardano/CLI/Types.hs index d744b6367b1..c7942d93083 100644 --- a/cardano-cli/src/Cardano/CLI/Types.hs +++ b/cardano-cli/src/Cardano/CLI/Types.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} module Cardano.CLI.Types ( CBORObject (..) @@ -11,6 +13,10 @@ module Cardano.CLI.Types , SigningKeyFile (..) , SocketPath (..) , ScriptFile (..) + , ScriptDataOrFile (..) + , ScriptRedeemerOrFile + , ScriptWitnessFiles (..) + , ScriptDatumOrFile (..) , TransferDirection(..) , TxOutAnyEra (..) , UpdateProposalFile (..) @@ -145,6 +151,39 @@ newtype VerificationKeyFile newtype ScriptFile = ScriptFile { unScriptFile :: FilePath } deriving (Eq, Show) +data ScriptDataOrFile = ScriptDataFile FilePath -- ^ By reference to a file + | ScriptDataValue ScriptData -- ^ By value + deriving (Eq, Show) + +type ScriptRedeemerOrFile = ScriptDataOrFile + +-- | This type is like 'ScriptWitness', but the file paths from which to load +-- the script witness data representation. +-- +-- It is era-independent, but witness context-dependent. +-- +data ScriptWitnessFiles witctx where + SimpleScriptWitnessFile :: ScriptFile + -> ScriptWitnessFiles witctx + + PlutusScriptWitnessFiles :: ScriptFile + -> ScriptDatumOrFile witctx + -> ScriptRedeemerOrFile + -> ExecutionUnits + -> ScriptWitnessFiles witctx + +deriving instance Show (ScriptWitnessFiles witctx) + +data ScriptDatumOrFile witctx where + ScriptDatumOrFileForTxIn :: ScriptDataOrFile + -> ScriptDatumOrFile WitCtxTxIn + + NoScriptDatumOrFileForMint :: ScriptDatumOrFile WitCtxMint + NoScriptDatumOrFileForStake :: ScriptDatumOrFile WitCtxStake + +deriving instance Show (ScriptDatumOrFile witctx) + + -- | Determines the direction in which the MIR certificate will transfer ADA. data TransferDirection = TransferToReserves | TransferToTreasury deriving Show diff --git a/scripts/plutus/always-fails-mint.plutus b/scripts/plutus/always-fails-mint.plutus new file mode 100644 index 00000000000..7f5c68c6972 --- /dev/null +++ b/scripts/plutus/always-fails-mint.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV1", + "description": "An example Plutus script (for minting context) that always fails", + "cborHex": "4701000020020061" +} diff --git a/scripts/plutus/always-fails-stake.plutus b/scripts/plutus/always-fails-stake.plutus new file mode 100644 index 00000000000..1822187d2e5 --- /dev/null +++ b/scripts/plutus/always-fails-stake.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV1", + "description": "An example Plutus script (for stake context) that always fails", + "cborHex": "4701000020020061" +} diff --git a/scripts/plutus/always-fails-txin.plutus b/scripts/plutus/always-fails-txin.plutus new file mode 100644 index 00000000000..15322da6b57 --- /dev/null +++ b/scripts/plutus/always-fails-txin.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV1", + "description": "An example Plutus script (for tx in context) that always fails", + "cborHex": "49010000200200200601" +} diff --git a/scripts/plutus/always-succeeds-mint.plutus b/scripts/plutus/always-succeeds-mint.plutus new file mode 100644 index 00000000000..e9ffdd1801f --- /dev/null +++ b/scripts/plutus/always-succeeds-mint.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV1", + "description": "An example Plutus script (for minting context) that always succeeds", + "cborHex": "4a01000020020020000101" +} diff --git a/scripts/plutus/always-succeeds-stake.plutus b/scripts/plutus/always-succeeds-stake.plutus new file mode 100644 index 00000000000..0d65781488b --- /dev/null +++ b/scripts/plutus/always-succeeds-stake.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV1", + "description": "An example Plutus script (for stake context) that always succeeds", + "cborHex": "4a01000020020020000101" +} diff --git a/scripts/plutus/always-succeeds-txin.plutus b/scripts/plutus/always-succeeds-txin.plutus new file mode 100644 index 00000000000..d306ead80bb --- /dev/null +++ b/scripts/plutus/always-succeeds-txin.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV1", + "description": "An example Plutus script (for tx in context) that always succeeds", + "cborHex": "4b0100002002002002000011" +}