diff --git a/marlowe/marlowe.cabal b/marlowe/marlowe.cabal index 761175e921..6ae9ab903e 100644 --- a/marlowe/marlowe.cabal +++ b/marlowe/marlowe.cabal @@ -179,6 +179,7 @@ test-suite marlowe-test template-haskell -any, streaming -any, plutus-pab -any, + plutus-core, async -any, prettyprinter -any, purescript-bridge -any, diff --git a/marlowe/src/Language/Marlowe/Client.hs b/marlowe/src/Language/Marlowe/Client.hs index 872ec86ee5..fbd1d28d4d 100644 --- a/marlowe/src/Language/Marlowe/Client.hs +++ b/marlowe/src/Language/Marlowe/Client.hs @@ -71,7 +71,6 @@ import Plutus.Contract as Contract hiding (OtherContractError, _OtherContractErr import qualified Plutus.Contract as Contract (ContractError (..)) import Plutus.Contract.Unsafe (unsafeGetSlotConfig) import Plutus.Contract.Wallet (getUnspentOutput) -import qualified Plutus.Contracts.Currency as Currency import Plutus.V1.Ledger.Api (toBuiltin) import PlutusPrelude (foldMapM, (<|>)) import qualified PlutusTx @@ -258,7 +257,7 @@ type MarloweContractState = Maybe MarloweEndpointResponse mkMarloweTypedValidator :: MarloweParams -> SmallTypedValidator -mkMarloweTypedValidator = smallUntypedValidator +mkMarloweTypedValidator = universalMarloweValidator minLovelaceDeposit :: Integer @@ -389,16 +388,17 @@ marlowePlutusContract = selectList [create, apply, applyNonmerkleized, auto, red tell $ Just $ EndpointSuccess reqId ApplyInputsResponse logInfo $ "MarloweApp contract input-application confirmed for inputs " <> show inputs <> "." marlowePlutusContract - redeem = promiseMap (mapError (review _MarloweError)) $ endpoint @"redeem" $ \(reqId, MarloweParams{rolesCurrency}, role, paymentAddress) -> catchError reqId "redeem" $ do + redeem = promiseMap (mapError (review _MarloweError)) $ endpoint @"redeem" $ \(reqId, params, role, paymentAddress) -> catchError reqId "redeem" $ do + let rolesCurrency = mkRolesCurrency params -- TODO: Move to debug log. logInfo $ "[DEBUG:redeem] rolesCurrency = " <> show rolesCurrency - let address = scriptHashAddress (mkRolePayoutValidatorHash rolesCurrency) + let address = scriptHashAddress mkRolePayoutValidatorHash logInfo $ "[DEBUG:redeem] address = " <> show address utxos <- utxosAt address let spendable txout = let - expectedDatumHash = datumHash (Datum $ PlutusTx.toBuiltinData role) + expectedDatumHash = datumHash (Datum $ PlutusTx.toBuiltinData (rolesCurrency, role)) dh = either id Ledger.datumHash <$> preview Ledger.ciTxOutDatum txout in dh == Just expectedDatumHash @@ -424,7 +424,7 @@ marlowePlutusContract = selectList [create, apply, applyNonmerkleized, auto, red -- must spend a role token for authorization <> Constraints.mustSpendAtLeast (Val.singleton rolesCurrency role 1) -- lookup for payout validator and role payouts - validator = rolePayoutScript rolesCurrency + validator = rolePayoutScript -- TODO: Move to debug log. logInfo $ "[DEBUG:redeem] constraints = " <> show constraints ownAddressLookups <- ownShelleyAddress paymentAddress @@ -561,27 +561,27 @@ setupMarloweParams owners roles = mapError (review _MarloweError) $ do -- TODO: Move to debug log. logInfo $ "[DEBUG:setupMarloweParams] txOut = " <> show txOut let utxo = Map.singleton txOutRef txOut - let theCurrency = Currency.OneShotCurrency - { curRefTransactionOutput = (h, i) - , curAmounts = AssocMap.fromList tokens - } - curVali = Currency.curPolicy theCurrency + let params = MarloweParams {rolePayoutValidatorHash = mkRolePayoutValidatorHash, uniqueTxOutRef = (h, i)} + let rolesSymbol = mkRolesCurrency params + let tokenAmounts = AssocMap.fromList tokens + let redeemer = Ledger.Redeemer $ PlutusTx.toBuiltinData tokenAmounts + let mintValue = Val.Value $ AssocMap.singleton rolesSymbol tokenAmounts + curVali = universalMarloweMintingPolicy params lookups = Constraints.mintingPolicy curVali <> Constraints.unspentOutputs utxo mintTx = Constraints.mustSpendPubKeyOutput txOutRef - <> Constraints.mustMintValue (Currency.mintedValue theCurrency) - let rolesSymbol = Ledger.scriptCurrencySymbol curVali + <> Constraints.mustMintValueWithRedeemer redeemer mintValue let minAdaTxOut = adaValueOf 2 let giveToParty (role, addr) = mustPayToShelleyAddress addr (Val.singleton rolesSymbol role 1 <> minAdaTxOut) distributeRoleTokens <- foldMapM giveToParty $ AssocMap.toList owners - let params = marloweParams rolesSymbol pure (params, mintTx <> distributeRoleTokens, lookups) else do let missingRoles = roles `Set.difference` Set.fromList (AssocMap.keys owners) let message = T.pack $ "You didn't specify owners of these roles: " <> show missingRoles throwing _ContractError $ Contract.OtherContractError message + ownShelleyAddress :: AddressInEra ShelleyEra -> Contract MarloweContractState s MarloweError (ScriptLookups Void) @@ -692,8 +692,9 @@ applyInputs params typedValidator timeInterval inputs = mapError (review _Marlow marloweParams :: CurrencySymbol -> MarloweParams marloweParams rolesCurrency = MarloweParams - { rolesCurrency = rolesCurrency - , rolePayoutValidatorHash = mkRolePayoutValidatorHash rolesCurrency} + { rolePayoutValidatorHash = mkRolePayoutValidatorHash + , uniqueTxOutRef = ("", 0) + } defaultMarloweParams :: MarloweParams @@ -810,7 +811,7 @@ mkStep :: -> TimeInterval -> [MarloweClientInput] -> Contract w MarloweSchema MarloweError MarloweData -mkStep MarloweParams{..} typedValidator timeInterval@(minTime, maxTime) clientInputs = do +mkStep params@MarloweParams{..} typedValidator timeInterval@(minTime, maxTime) clientInputs = do let times = Interval.Interval @@ -863,6 +864,7 @@ mkStep MarloweParams{..} typedValidator timeInterval@(minTime, maxTime) clientIn logInfo $ "[DEBUG:mkStep] txId = " <> show txId pure marloweData where + rolesCurrency = mkRolesCurrency params evaluateTxContstraints :: MarloweData -> Ledger.POSIXTimeRange -> Tx.TxOutRef diff --git a/marlowe/src/Language/Marlowe/Client/History.hs b/marlowe/src/Language/Marlowe/Client/History.hs index 0aadf4504a..01f70f01d4 100644 --- a/marlowe/src/Language/Marlowe/Client/History.hs +++ b/marlowe/src/Language/Marlowe/Client/History.hs @@ -44,7 +44,7 @@ import Data.List (nub) import Data.Maybe (catMaybes, isJust, isNothing, mapMaybe) import Data.Tuple.Extra (secondM) import GHC.Generics (Generic) -import Language.Marlowe.Scripts (SmallTypedValidator, TypedMarloweValidator, smallUntypedValidator) +import Language.Marlowe.Scripts (SmallTypedValidator, TypedMarloweValidator, mkRolesCurrency, smallUntypedValidator) import Language.Marlowe.Semantics (MarloweData, MarloweParams (..), TransactionInput (TransactionInput)) import Ledger (ChainIndexTxOut (..), ciTxOutAddress, toTxOut) import Ledger.TimeSlot (slotRangeToPOSIXTimeRange) @@ -281,8 +281,9 @@ creationTxOut :: MarloweParams -- ^ The Marlowe validator parameters. -> Address -- ^ The Marlowe validator address. -> ChainIndexTx -- ^ The transaction to be checked. -> Maybe MarloweTxOutRef -- ^ The creation-transaction output and the contract, if any. -creationTxOut MarloweParams{..} address citx = +creationTxOut params address citx = do + let rolesCurrency = mkRolesCurrency params -- Ensure that the transaction minted the role currency. guard . elem (ScriptHash $ unCurrencySymbol rolesCurrency) diff --git a/marlowe/src/Language/Marlowe/Scripts.hs b/marlowe/src/Language/Marlowe/Scripts.hs index 19cb1fd3f1..cb6c398d42 100644 --- a/marlowe/src/Language/Marlowe/Scripts.hs +++ b/marlowe/src/Language/Marlowe/Scripts.hs @@ -20,8 +20,8 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -{-# OPTIONS_GHC -fno-specialise #-} +-- {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + module Language.Marlowe.Scripts where import GHC.Generics @@ -30,17 +30,19 @@ import Language.Marlowe.Semantics import Language.Marlowe.SemanticsTypes import Ledger import Ledger.Ada (adaSymbol) -import Ledger.Constraints.OnChain -import Ledger.Constraints.TxConstraints +import qualified Ledger.Contexts as V import qualified Ledger.Interval as Interval import qualified Ledger.Typed.Scripts as Scripts import qualified Ledger.Value as Val +import Plutus.V1.Ledger.Credential (Credential (..)) +import Plutus.V1.Ledger.Scripts as Scripts import PlutusTx (makeIsDataIndexed, makeLift) import qualified PlutusTx import qualified PlutusTx.AssocMap as AssocMap import PlutusTx.Prelude import qualified Prelude as Haskell import Unsafe.Coerce +import qualified UntypedPlutusCore as UPLC type MarloweTimeRange = (POSIXTime, POSIXTime) type MarloweInput = [MarloweTxInput] @@ -63,41 +65,152 @@ data MarloweTxInput = Input InputContent deriving anyclass (Pretty) -rolePayoutScript :: CurrencySymbol -> Validator -rolePayoutScript symbol = mkValidatorScript ($$(PlutusTx.compile [|| wrapped ||]) `PlutusTx.applyCode` PlutusTx.liftCode symbol) +rolePayoutScript :: Validator +rolePayoutScript = mkValidatorScript ($$(PlutusTx.compile [|| wrapped ||])) where - wrapped s = Scripts.wrapValidator (rolePayoutValidator s) + wrapped = Scripts.wrapValidator rolePayoutValidator {-# INLINABLE rolePayoutValidator #-} -rolePayoutValidator :: CurrencySymbol -> TokenName -> () -> ScriptContext -> Bool -rolePayoutValidator currency role _ ctx = +rolePayoutValidator :: (CurrencySymbol, TokenName) -> () -> ScriptContext -> Bool +rolePayoutValidator (currency, role) _ ctx = Val.valueOf (valueSpent (scriptContextTxInfo ctx)) currency role > 0 -mkRolePayoutValidatorHash :: CurrencySymbol -> ValidatorHash -mkRolePayoutValidatorHash symbol = validatorHash (rolePayoutScript symbol) +mkRolePayoutValidatorHash :: ValidatorHash +mkRolePayoutValidatorHash = validatorHash rolePayoutScript defaultRolePayoutValidatorHash :: ValidatorHash -defaultRolePayoutValidatorHash = mkRolePayoutValidatorHash adaSymbol +defaultRolePayoutValidatorHash = mkRolePayoutValidatorHash + + +-- {-# INLINABLE smallMarloweValidator #-} + +{- + Off-chain + Contract -> [role] + Contract -> [role] -> [(role, amount)] + () -> TxInRef + TxInRef -> rolePayoutValidatorHash (unique, not enforced) + [(role, amount)], txInRef, rolePayoutValidatorHash -> MarloweParams + [(role, amount)], txInRef, rolePayoutValidatorHash, initial MarloweDataHash -> UniversalHash (MPSHash == ValidatorHash == CurrencySymbol) + MPS checks during minting, either: + - role tokens minted && a single TxOut exists with same hash validator, and DatumHash == initial MarloweDataHash + - role tokens can be destroyed + Validator checks + - single input-output with same TxInRef + -} +mkRolesCurrency params = let + ValidatorHash hash = Scripts.validatorHash $ universalMarloweValidator params + in Val.CurrencySymbol hash + {-# INLINABLE smallMarloweValidator #-} smallMarloweValidator :: MarloweParams + -> (BuiltinData -> Contract) + -> (BuiltinData -> ScriptContext) -> MarloweData -> MarloweInput - -> ScriptContext - -> Bool -smallMarloweValidator MarloweParams{rolesCurrency, rolePayoutValidatorHash} + -> BuiltinData + -> () +smallMarloweValidator MarloweParams{rolePayoutValidatorHash} + fromDataToContract + fromDataToScriptContext MarloweData{..} marloweTxInputs - ctx@ScriptContext{scriptContextTxInfo} = do + builtInDataCtx = do + + let ctx@ScriptContext{scriptContextTxInfo} = fromDataToScriptContext builtInDataCtx + + let findOwnInput :: ScriptContext -> Maybe TxInInfo + findOwnInput ScriptContext{scriptContextTxInfo=TxInfo{txInfoInputs}, scriptContextPurpose=Spending txOutRef} = + find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs + findOwnInput _ = Nothing + + ownInput :: TxInInfo + ownInput@TxInInfo{txInInfoResolved=TxOut{txOutAddress=ownAddress@(Address (ScriptCredential (ValidatorHash ownValidatorHash)) _)}} = + case findOwnInput ctx of + Just ownTxInInfo -> + case filter (sameValidatorHash ownTxInInfo) (txInfoInputs scriptContextTxInfo) of + [i] -> i + _ -> traceError "I1" -- multiple Marlowe contract inputs with the same address, it's forbidden + _ -> traceError "I0" {-"Can't find validation input"-} + + rolesCurrency = Val.CurrencySymbol ownValidatorHash + + sameValidatorHash:: TxInInfo -> TxInInfo -> Bool + sameValidatorHash + TxInInfo{txInInfoResolved=TxOut{txOutAddress=Address (ScriptCredential vh1) _}} + TxInInfo{txInInfoResolved=TxOut{txOutAddress=Address (ScriptCredential vh2) _}} = vh1 == vh2 + sameValidatorHash _ _ = False + + + findDatumHash' :: PlutusTx.ToData o => o -> Maybe DatumHash + findDatumHash' datum = findDatumHash (Datum $ PlutusTx.toBuiltinData datum) scriptContextTxInfo + + checkOwnOutputConstraint :: MarloweData -> Val.Value -> Bool + checkOwnOutputConstraint ocDatum ocValue = + let hsh = findDatumHash' ocDatum + in traceIfFalse "L1" -- "Output constraint" + $ checkScriptOutput ownAddress hsh ocValue getContinuingOutput + + getContinuingOutput :: TxOut + getContinuingOutput = case filter (\TxOut{txOutAddress} -> ownAddress == txOutAddress) allOutputs of + [out] -> out + _ -> traceError "O0" -- no continuation or multiple Marlowe contract outputs, it's forbidden + + checkScriptOutput addr hsh value TxOut{txOutAddress, txOutValue, txOutDatumHash=Just svh} = + txOutValue == value && hsh == Just svh && txOutAddress == addr + checkScriptOutput _ _ _ _ = False + + allOutputs :: [TxOut] + allOutputs = txInfoOutputs scriptContextTxInfo + + marloweTxInputToInput :: MarloweTxInput -> Input + marloweTxInputToInput (MerkleizedTxInput input hash) = + case findDatum (DatumHash hash) scriptContextTxInfo of + Just (Datum d) -> let + -- continuation = PlutusTx.unsafeFromBuiltinData d + continuation = fromDataToContract d + in MerkleizedInput input hash continuation + Nothing -> traceError "H" + marloweTxInputToInput (Input input) = NormalInput input + + validateInputs :: [Input] -> Bool + validateInputs inputs = all (validateInputWitness . getInputContent) inputs + where + validateInputWitness :: InputContent -> Bool + validateInputWitness input = + case input of + IDeposit _ party _ _ -> validatePartyWitness party + IChoice (ChoiceId _ party) _ -> validatePartyWitness party + INotify -> True + where + validatePartyWitness (PK pk) = traceIfFalse "S" $ scriptContextTxInfo `txSignedBy` pk + validatePartyWitness (Role role) = traceIfFalse "T" -- "Spent value not OK" + $ Val.singleton rolesCurrency role 1 `Val.leq` valueSpent scriptContextTxInfo + + collectDeposits :: InputContent -> Val.Value + collectDeposits (IDeposit _ _ (Token cur tok) amount) = Val.singleton cur tok amount + collectDeposits _ = zero + + payoutByParty :: Payment -> AssocMap.Map Party Val.Value + payoutByParty (Payment _ (Party party) money) = AssocMap.singleton party money + payoutByParty (Payment _ (Account _) _) = AssocMap.empty + + payoutConstraints :: [(Party, Val.Value)] -> Bool + payoutConstraints payoutsByParty = all payoutToTxOut payoutsByParty + where + payoutToTxOut (party, value) = case party of + PK pk -> traceIfFalse "P" $ value `Val.leq` valuePaidTo scriptContextTxInfo pk + Role role -> let + hsh = findDatumHash' (rolesCurrency, role) + addr = Ledger.scriptHashAddress rolePayoutValidatorHash + in traceIfFalse "R" $ any (checkScriptOutput addr hsh value) allOutputs - let ownInput = case findOwnInput ctx of - Just i -> i - _ -> traceError "I0" {-"Can't find validation input"-} let scriptInValue = txOutValue $ txInInfoResolved ownInput let interval = case txInfoValidRange scriptContextTxInfo of @@ -147,12 +260,10 @@ smallMarloweValidator MarloweParams{rolesCurrency, rolePayoutValidatorHash} totalIncome = foldMap (collectDeposits . getInputContent) inputs totalPayouts = foldMap snd payoutsByParty finalBalance = inputBalance + totalIncome - totalPayouts - outConstrs = ScriptOutputConstraint - { ocDatum = marloweData - , ocValue = finalBalance - } - in checkOwnOutputConstraint ctx outConstrs - preconditionsOk && inputsOk && payoutsOk && checkContinuation + in checkOwnOutputConstraint marloweData finalBalance + if preconditionsOk && inputsOk && payoutsOk && checkContinuation + then () else traceError "M" + Error TEAmbiguousTimeIntervalError -> traceError "E1" Error TEApplyNoMatchError -> traceError "E2" Error (TEIntervalError (InvalidInterval _)) -> traceError "E3" @@ -160,74 +271,165 @@ smallMarloweValidator MarloweParams{rolesCurrency, rolePayoutValidatorHash} Error TEUselessTransaction -> traceError "E5" Error TEHashMismatch -> traceError "E6" - where - checkScriptOutput addr hsh value TxOut{txOutAddress, txOutValue, txOutDatumHash=Just svh} = - txOutValue == value && hsh == Just svh && txOutAddress == addr - checkScriptOutput _ _ _ _ = False - - allOutputs :: [TxOut] - allOutputs = txInfoOutputs scriptContextTxInfo - - marloweTxInputToInput :: MarloweTxInput -> Input - marloweTxInputToInput (MerkleizedTxInput input hash) = - case findDatum (DatumHash hash) scriptContextTxInfo of - Just (Datum d) -> let - continuation = PlutusTx.unsafeFromBuiltinData d - in MerkleizedInput input hash continuation - Nothing -> traceError "H" - marloweTxInputToInput (Input input) = NormalInput input - - validateInputs :: [Input] -> Bool - validateInputs inputs = all (validateInputWitness . getInputContent) inputs - where - validateInputWitness :: InputContent -> Bool - validateInputWitness input = - case input of - IDeposit _ party _ _ -> validatePartyWitness party - IChoice (ChoiceId _ party) _ -> validatePartyWitness party - INotify -> True - where - validatePartyWitness (PK pk) = traceIfFalse "S" $ scriptContextTxInfo `txSignedBy` pk - validatePartyWitness (Role role) = traceIfFalse "T" -- "Spent value not OK" - $ Val.singleton rolesCurrency role 1 `Val.leq` valueSpent scriptContextTxInfo - - collectDeposits :: InputContent -> Val.Value - collectDeposits (IDeposit _ _ (Token cur tok) amount) = Val.singleton cur tok amount - collectDeposits _ = zero - - payoutByParty :: Payment -> AssocMap.Map Party Val.Value - payoutByParty (Payment _ (Party party) money) = AssocMap.singleton party money - payoutByParty (Payment _ (Account _) _) = AssocMap.empty - - payoutConstraints :: [(Party, Val.Value)] -> Bool - payoutConstraints payoutsByParty = all payoutToTxOut payoutsByParty - where - payoutToTxOut (party, value) = case party of - PK pk -> traceIfFalse "P" $ value `Val.leq` valuePaidTo scriptContextTxInfo pk - Role role -> let - dataValue = Datum $ PlutusTx.toBuiltinData role - hsh = findDatumHash dataValue scriptContextTxInfo - addr = Ledger.scriptHashAddress rolePayoutValidatorHash - in traceIfFalse "R" $ any (checkScriptOutput addr hsh value) allOutputs - - -smallTypedValidator :: MarloweParams -> Scripts.TypedValidator TypedMarloweValidator -smallTypedValidator = Scripts.mkTypedValidatorParam @TypedMarloweValidator - $$(PlutusTx.compile [|| smallMarloweValidator ||]) - $$(PlutusTx.compile [|| wrap ||]) - where - wrap = Scripts.wrapValidator - smallUntypedValidator :: MarloweParams -> Scripts.TypedValidator TypedMarloweValidator smallUntypedValidator params = let - wrapped s = Scripts.wrapValidator (smallMarloweValidator s) + -- wrapped s = Scripts.wrapValidator (smallMarloweValidator s) + wrapped s = wrapper (smallMarloweValidator s) typed = mkValidatorScript ($$(PlutusTx.compile [|| wrapped ||]) `PlutusTx.applyCode` PlutusTx.liftCode params) -- Yeah, I know. It works, though. -- Remove this when Typed Validator has the same size as untyped. in unsafeCoerce (Scripts.unsafeMkTypedValidator typed) +smallUntypedValidatorScript :: MarloweParams -> Scripts.Script +smallUntypedValidatorScript = getValidator . Scripts.validatorScript . smallUntypedValidator + + +applyScript :: Script -> Script -> Script +applyScript (Script f) (Script arg) = Script $ UPLC.applyProgram f arg + + +{-# INLINABLE marloweMonetaryPolicy #-} +marloweMonetaryPolicy :: MarloweParams -> AssocMap.Map TokenName Integer -> ScriptContext -> () +marloweMonetaryPolicy MarloweParams{uniqueTxOutRef=(refHash, refIdx)} tokens ctx@ScriptContext{scriptContextTxInfo=txinfo} = let + -- see note [Obtaining the currency symbol] + ownSymbol@Val.CurrencySymbol{unCurrencySymbol=ownHash} = ownCurrencySymbol ctx + ownValidatorHash = ValidatorHash ownHash + + minted = V.txInfoMint txinfo + expected = Val.Value $ AssocMap.singleton ownSymbol tokens + + -- True if the pending transaction mints the amount of + -- currency that we expect + mintOK = + let v = expected == minted + in traceIfFalse "C0" {-"Value minted different from expected"-} v + + -- True if the pending transaction spends the output + -- identified by @(refHash, refIdx)@ + txOutputSpent = + let v = V.spendsOutput txinfo refHash refIdx + in traceIfFalse "C1" {-"Pending transaction does not spend the designated transaction output"-} v + + marloweTxOutExists TxOut{txOutAddress=Address (ScriptCredential vh) _} | vh == ownValidatorHash = True + marloweTxOutExists _ = False + + -- Ensure that a TxOut exists with ValidatorHash same as this MintingPolicyHash + marloweContractTxOutExists = any marloweTxOutExists $ txInfoOutputs txinfo + + in if mintOK && txOutputSpent && marloweContractTxOutExists then () else traceError "E" + + +{-- * Note [Universal Script] + + How to make a single script that works as both a MintingPolicy and as a Validator. + + A MintingPolicy script is a function of 2 arguments, and has a signature + + mintingPolicy :: BuiltinData -> BuiltinData -> () + mintingPolicy redeemer context = ... + + and a Validator is a function of 3 arguments, and has a signature + + validator :: BuiltinData -> BuiltinData -> BuiltinData -> () + validator redeemer datum context = ... + + We can distinguish the context in which a script is called by + checking whether the second argument is 'ScriptContext' or not. + We can do this by trying do deserialize the second argument into ScriptContext + using 'fromBuiltinData'. If it deserializes successfully we are called as a Minting Policy, + otherwise it's a Validator context. + + To be run in both contexts, the universal script must expect 2 arguments, + 'Redeemer' and 'ScriptContext' for of MintingPolicy, and 'Redeemer' and 'Datum' for a Validator. + In case of Minting Policy it should return () or error. + But as a Validator, the script should return a continuation: + (\ctx :: ScriptContext -> validator logic) + + This obviously does not typecheck as Haskell can't unify () and ScriptContext -> () types. + Moreover, PlutusTx does not support usage of 'unsafeCoerce'. + + In order to convince the compiler we are going to exploit the fact + that Plutus script is actually an untyped lambda calculus. + + We parameterize our 'universalScript' with a validator function 'f' that has a signature + + f :: BuiltinData -> BuiltinData -> () + + universalPlutusCode :: (BuiltinData -> BuiltinData -> ()) -> BuiltinData -> BuiltinData -> () + universalPlutusCode f a b = if isScriptContext b then mintingPolicy a b else f a b + + While our validator code would look like that: + + validatorPlutusCode :: BuiltinData -> BuiltinData -> BuiltinData -> () + validatorPlutusCode redeemer datum context = ... + + Compile thes function to Plutus Script: + + universalScript = Scripts.fromCompiledCode $$(PlutusTx.compile [|| universalPlutusCode ||] + validatorScript = Scripts.fromCompiledCode $$(PlutusTx.compile [|| validatorPlutusCode ||] + + Here is the trick: we apply universalScript to validatorScript as an argument. + + Then, the 'validatorPlutusCode' (binded as 'f' in our 'universalScript') + applied to 2 arguments will return a continuation(\ctx -> ...). + And that's precisely what we wanted! + + There is a significant drawback with this approach, though. + As we compile these 2 scripts separately, the common Plutus code gets generated and included twice, + because Haskell compiler can't optimize/reuse it. + The large amount of code is generated by 'unsafeFromBuiltinData' function, almost 4k bytes. + Simplest solution is to pass instantiations of the function as arguments into 'validatorPlutusCode' + and reuse it manually. + + In the future we expect the serialization to become a builtin, so it won't be a size issue. + + Another possibility could be adding support for usafeCoerce to PlutusTx compiler. + Then we could just directly 'unsafeCoerse (f a b) :: ()' in the 'universalScript'. +-} + +universalMarlowePlutusCode :: MarloweParams -> ((BuiltinData -> Contract) -> (BuiltinData -> ScriptContext) -> MarloweData -> MarloweInput -> ()) -> BuiltinData -> BuiltinData -> () +universalMarlowePlutusCode mp f a b = let + -- if script's second argument is ScriptContext then it's a MintingPolicy + -- otherwise, it's a Validator + mctx :: Maybe ScriptContext + mctx = PlutusTx.fromBuiltinData b + in case mctx of + Just ctx -> marloweMonetaryPolicy mp (PlutusTx.unsafeFromBuiltinData a) ctx + -- this call should return a continuation (\scriptContext -> validator logic) + _ -> f PlutusTx.unsafeFromBuiltinData PlutusTx.unsafeFromBuiltinData + (PlutusTx.unsafeFromBuiltinData a) (PlutusTx.unsafeFromBuiltinData b) + + +{-# INLINABLE wrapper #-} +wrapper :: ((BuiltinData -> Contract) -> (BuiltinData -> ScriptContext) -> MarloweData -> MarloweInput -> BuiltinData -> ()) -> BuiltinData -> BuiltinData -> BuiltinData -> () +wrapper f a b c = f PlutusTx.unsafeFromBuiltinData PlutusTx.unsafeFromBuiltinData (PlutusTx.unsafeFromBuiltinData a) (PlutusTx.unsafeFromBuiltinData b) c + + +marloweMPS :: MarloweParams -> Scripts.Script +marloweMPS params = Scripts.fromCompiledCode + ($$(PlutusTx.compile [|| universalMarlowePlutusCode ||]) + `PlutusTx.applyCode` PlutusTx.liftCode params) + + +universalMarloweScript :: MarloweParams -> Scripts.Script +universalMarloweScript params = applyScript mps validator + where + validator = smallUntypedValidatorScript params + mps = marloweMPS params + + +universalMarloweValidator :: MarloweParams -> Scripts.TypedValidator TypedMarloweValidator +universalMarloweValidator params = unsafeCoerce (Scripts.unsafeMkTypedValidator validator) + where + validator = Validator $ universalMarloweScript params + + +universalMarloweMintingPolicy :: MarloweParams -> MintingPolicy +universalMarloweMintingPolicy params = MintingPolicy $ universalMarloweScript params + + defaultTxValidationRange :: POSIXTime defaultTxValidationRange = 10000 diff --git a/marlowe/src/Language/Marlowe/Semantics.hs b/marlowe/src/Language/Marlowe/Semantics.hs index 7631da8051..de4d229b8c 100644 --- a/marlowe/src/Language/Marlowe/Semantics.hs +++ b/marlowe/src/Language/Marlowe/Semantics.hs @@ -56,7 +56,7 @@ import Language.Marlowe.SemanticsTypes (AccountId, Accounts, Action (..), Case ( Input (..), InputContent (..), IntervalError (..), IntervalResult (..), Money, Observation (..), Party, Payee (..), State (..), TimeInterval, Token (..), Value (..), ValueId, emptyState, getAction, getInputContent, inBounds) -import Ledger (POSIXTime (..), ValidatorHash) +import Ledger (POSIXTime (..), TxId, ValidatorHash) import Ledger.Value (CurrencySymbol (..)) import qualified Ledger.Value as Val import PlutusTx (makeIsDataIndexed) @@ -211,7 +211,7 @@ data MarloweData = MarloweData { data MarloweParams = MarloweParams { rolePayoutValidatorHash :: ValidatorHash, - rolesCurrency :: CurrencySymbol + uniqueTxOutRef :: (TxId, Integer) } deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord) deriving anyclass (FromJSON,ToJSON) diff --git a/marlowe/test/Spec/Marlowe/Marlowe.hs b/marlowe/test/Spec/Marlowe/Marlowe.hs index a4465419a8..a6df2f12a1 100644 --- a/marlowe/test/Spec/Marlowe/Marlowe.hs +++ b/marlowe/test/Spec/Marlowe/Marlowe.hs @@ -45,11 +45,12 @@ import Language.Haskell.Interpreter (Extension (OverloadedStrings), MonadInterpr import qualified Language.Marlowe as M ((%)) import Language.Marlowe.Analysis.FSSemantics import Language.Marlowe.Client -import Language.Marlowe.Scripts (MarloweInput, rolePayoutScript, smallTypedValidator, smallUntypedValidator) +import Language.Marlowe.Scripts (MarloweInput, marloweMPS, mkRolesCurrency, rolePayoutScript, smallUntypedValidator, + universalMarloweScript) import Language.Marlowe.Semantics import Language.Marlowe.SemanticsTypes import Language.Marlowe.Util -import Ledger (POSIXTime (..), PaymentPubKeyHash (..), PubKeyHash (..), pubKeyHash, validatorHash) +import Ledger (POSIXTime (..), PaymentPubKeyHash (..), PubKeyHash (..), Script (..), pubKeyHash, validatorHash) import Ledger.Ada (adaValueOf, lovelaceValueOf) import Ledger.Constraints.TxConstraints (TxConstraints) import Ledger.TimeSlot (SlotConfig (..)) @@ -61,6 +62,7 @@ import qualified Plutus.Contract.Test as T import Plutus.Contract.Types (_observableState) import qualified Plutus.Trace.Emulator as Trace import Plutus.Trace.Emulator.Types (instContractState) +import PlutusCore.Pretty import qualified PlutusTx.AssocMap as AssocMap import PlutusTx.Builtins (emptyByteString, sha2_256) import PlutusTx.Lattice @@ -85,8 +87,7 @@ tests = testGroup "Marlowe" , testCase "State serializes into valid JSON" stateSerialization , testCase "Input serializes into valid JSON" inputSerialization , testGroup "Validator size is reasonable" - [ testCase "Typed validator size" typedValidatorSize - , testCase "Untyped validator size" untypedValidatorSize + [ testCase "Untyped validator size" untypedValidatorSize ] , testCase "Mul analysis" mulAnalysisTest , testCase "Div analysis" divAnalysisTest @@ -260,8 +261,8 @@ trustFundTest = checkPredicateOptions defaultCheckOptions "Trust Fund Contract" -- T..&&. emulatorLog (const False) "" T..&&. assertNotDone marlowePlutusContract (Trace.walletInstanceTag alice) "contract should not have any errors" T..&&. assertNotDone marlowePlutusContract (Trace.walletInstanceTag bob) "contract should not have any errors" - T..&&. walletFundsChange alice (lovelaceValueOf (-minAda-25_600_000) <> Val.singleton (rolesCurrency params) "alice" 1) - T..&&. walletFundsChange bob (lovelaceValueOf (minAda+25_600_000) <> Val.singleton (rolesCurrency params) "bob" 1) + T..&&. walletFundsChange alice (lovelaceValueOf (-minAda-25_600_000) <> Val.singleton (mkRolesCurrency params) "alice" 1) + T..&&. walletFundsChange bob (lovelaceValueOf (minAda+25_600_000) <> Val.singleton (mkRolesCurrency params) "bob" 1) -- TODO Commented out because the new chain index does not allow to fetch -- all transactions that modified an address. Need to find an alternative -- way. @@ -348,22 +349,24 @@ trustFundTest = checkPredicateOptions defaultCheckOptions "Trust Fund Contract" uniqueContractHash :: IO () uniqueContractHash = do - let hash1 = Scripts.validatorHash $ smallTypedValidator (marloweParams "11") - let hash2 = Scripts.validatorHash $ smallTypedValidator (marloweParams "22") - let hash3 = Scripts.validatorHash $ smallTypedValidator (marloweParams "22") + let hash1 = Scripts.validatorHash $ smallUntypedValidator (marloweParams "11") + let hash2 = Scripts.validatorHash $ smallUntypedValidator (marloweParams "22") + let hash3 = Scripts.validatorHash $ smallUntypedValidator (marloweParams "22") assertBool "Hashes must be different" (hash1 /= hash2) assertBool "Hashes must be same" (hash2 == hash3) -typedValidatorSize :: IO () -typedValidatorSize = do - let validator = Scripts.validatorScript $ smallTypedValidator defaultMarloweParams - let vsize = SBS.length. SBS.toShort . LB.toStrict $ Serialise.serialise validator - assertBool ("smallTypedValidator is too large " <> show vsize) (vsize < 17200) untypedValidatorSize :: IO () untypedValidatorSize = do let validator = Scripts.validatorScript $ smallUntypedValidator defaultMarloweParams + let validator2 = universalMarloweScript defaultMarloweParams + let Script plc = marloweMPS defaultMarloweParams let vsize = SBS.length. SBS.toShort . LB.toStrict $ Serialise.serialise validator + let vsize2 = SBS.length. SBS.toShort . LB.toStrict $ Serialise.serialise validator2 + let vsize3 = SBS.length. SBS.toShort . LB.toStrict $ Serialise.serialise (marloweMPS defaultMarloweParams) + -- print $ prettyPlcReadableDebug plc + -- print $ prettyPlcReadableDebug wpr + putStrLn $ "smallUntypedValidator " <> show vsize <> ", universalMarloweScript " <> show vsize2 <> ", marloweMPS " <> show vsize3 assertBool ("smallUntypedValidator is too large " <> show vsize) (vsize < 15200) extractContractRolesTest :: IO ()