Merge remote-tracking branch 'origin' into SCP-4715

marlowe-runtime/cli/Language/Marlowe/Runtime/CLI/Command/Apply.hs

@@ -25,7 +25,7 @@ import Language.Marlowe.Runtime.CLI.Option (txOutRefParser)
 import Language.Marlowe.Runtime.ChainSync.Api (unPolicyId)
 import Language.Marlowe.Runtime.Core.Api
   (ContractId(..), IsMarloweVersion(..), MarloweVersion(MarloweV1), MarloweVersionTag(..))
-import Language.Marlowe.Runtime.Transaction.Api (ApplyInputsError, MarloweTxCommand(ApplyInputs))
+import Language.Marlowe.Runtime.Transaction.Api (ApplyInputsError, InputsApplied(..), MarloweTxCommand(ApplyInputs))
 import qualified Language.Marlowe.Util as V1
 import Options.Applicative
 import qualified Plutus.V1.Ledger.Api as P
@@ -217,7 +217,7 @@ runApplyCommand TxCommand { walletAddresses, signingMethod, subCommand=V1ApplyCo
     validityUpperBound'= posixTimeToUTCTime <$> validityUpperBound
 
     cmd = ApplyInputs MarloweV1 walletAddresses contractId validityLowerBound' validityUpperBound' inputs'
-  txBody <- ExceptT $ first ApplyFailed <$> runTxCommand cmd
+  InputsApplied{txBody} <- ExceptT $ first ApplyFailed <$> runTxCommand cmd
   case signingMethod of
     Manual outputFile -> do
       ExceptT $ liftIO $ first TransactionFileWriteFailed <$> C.writeFileTextEnvelope outputFile Nothing txBody

marlowe-runtime/marlowe-runtime.cabal

@@ -190,6 +190,7 @@ library web
     , servant-server
     , servant-openapi3
     , text
+    , time
 
 library web-server
   import: lang
@@ -237,6 +238,7 @@ library web-server
     , stm
     , stm-delay
     , text
+    , time
     , transformers
     , transformers-base
     , typed-protocols
@@ -476,6 +478,7 @@ test-suite marlowe-runtime-test
     , plutus-tx
     , plutus-ledger-api
     , QuickCheck
+    , hedgehog-quickcheck
     , some
     , stm
     , tasty

marlowe-runtime/src/Language/Marlowe/Runtime/Transaction/Api.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE EmptyDataDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -12,6 +13,7 @@ module Language.Marlowe.Runtime.Transaction.Api
   , ContractCreated(..)
   , CreateBuildupError(..)
   , CreateError(..)
+  , InputsApplied(..)
   , JobId(..)
   , LoadMarloweContextError(..)
   , MarloweTxCommand(..)
@@ -130,6 +132,40 @@ instance IsCardanoEra era => Binary (ContractCreated era 'V1) where
     let version = MarloweV1
     pure ContractCreated{..}
 
+data InputsApplied era v = InputsApplied
+  { version :: MarloweVersion v
+  , contractId :: ContractId
+  , input :: TransactionScriptOutput v
+  , output :: Maybe (TransactionScriptOutput v)
+  , invalidBefore :: UTCTime
+  , invalidHereafter :: UTCTime
+  , inputs :: Redeemer v
+  , txBody :: TxBody era
+  }
+
+deriving instance Show (InputsApplied BabbageEra 'V1)
+deriving instance Eq (InputsApplied BabbageEra 'V1)
+
+instance IsCardanoEra era => Binary (InputsApplied era 'V1) where
+  put InputsApplied{..} = do
+    put contractId
+    put input
+    put output
+    putUTCTime invalidBefore
+    putUTCTime invalidHereafter
+    putRedeemer MarloweV1 inputs
+    putTxBody txBody
+  get = do
+    let version = MarloweV1
+    contractId <- get
+    input <- get
+    output <- get
+    invalidBefore <- getUTCTime
+    invalidHereafter <- getUTCTime
+    inputs <- getRedeemer MarloweV1
+    txBody <- getTxBody
+    pure InputsApplied{..}
+
 -- | The low-level runtime API for building and submitting transactions.
 data MarloweTxCommand status err result where
   -- | Construct a transaction that starts a new Marlowe contract. The
@@ -172,9 +208,7 @@ data MarloweTxCommand status err result where
     -- is computed from the contract.
     -> Redeemer v
     -- ^ The inputs to apply.
-    -> MarloweTxCommand Void (ApplyInputsError v)
-        ( TxBody BabbageEra -- The unsigned tx body, to be signed by a wallet.
-        )
+    -> MarloweTxCommand Void (ApplyInputsError v) (InputsApplied BabbageEra v)
 
   -- | Construct a transaction that withdraws available assets from an active
   -- Marlowe contract for a set of roles in the contract. The resulting,
@@ -206,7 +240,7 @@ data MarloweTxCommand status err result where
 instance Command MarloweTxCommand where
   data Tag MarloweTxCommand status err result where
     TagCreate :: MarloweVersion v -> Tag MarloweTxCommand Void (CreateError v) (ContractCreated BabbageEra v)
-    TagApplyInputs :: MarloweVersion v -> Tag MarloweTxCommand Void (ApplyInputsError v) (TxBody BabbageEra)
+    TagApplyInputs :: MarloweVersion v -> Tag MarloweTxCommand Void (ApplyInputsError v) (InputsApplied BabbageEra v)
     TagWithdraw :: MarloweVersion v -> Tag MarloweTxCommand Void (WithdrawError v) (TxBody BabbageEra)
     TagSubmit :: Tag MarloweTxCommand SubmitStatus SubmitError BlockHeader
 
@@ -344,13 +378,13 @@ instance Command MarloweTxCommand where
 
   putResult = \case
     TagCreate MarloweV1 -> put
-    TagApplyInputs _ -> putTxBody
+    TagApplyInputs MarloweV1 -> put
     TagWithdraw _ -> putTxBody
     TagSubmit -> put
 
   getResult = \case
     TagCreate MarloweV1 -> get
-    TagApplyInputs _ -> getTxBody
+    TagApplyInputs MarloweV1 -> get
     TagWithdraw _ -> getTxBody
     TagSubmit -> get
 
@@ -429,7 +463,7 @@ data LoadMarloweContextError
   deriving anyclass Binary
 
 data SubmitError
-  = SubmitException
+  = SubmitException String
   | SubmitFailed String -- should be from show TxValidationErrorInMode
   | TxDiscarded
   deriving (Eq, Show, Generic, Binary)

marlowe-runtime/src/Language/Marlowe/Runtime/Transaction/BuildConstraints.hs

@@ -17,7 +17,7 @@ import Control.Category ((>>>))
 import Control.Error (note)
 import Control.Monad ((<=<), (>=>))
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Writer (WriterT(runWriterT), execWriterT, tell)
+import Control.Monad.Trans.Writer (WriterT(runWriterT), tell)
 import Data.Bifunctor (bimap, first)
 import Data.Foldable (for_, traverse_)
 import Data.Function (on)
@@ -250,6 +250,8 @@ buildCreateConstraintsV1 walletCtx roles metadata minAda contract = do
           uselessRolePolicyId  = PolicyId . PV2.fromBuiltin . PV2.unCurrencySymbol $ PV2.adaSymbol
         pure uselessRolePolicyId
 
+type ApplyResults v = (UTCTime, UTCTime, Maybe (Assets, Datum v))
+
 -- applies an input to a contract.
 buildApplyInputsConstraints
   :: SystemStart
@@ -261,7 +263,7 @@ buildApplyInputsConstraints
                    -- If not specified, this is computed from the the timeouts
                    -- in the contract.
   -> Redeemer v -- ^ The inputs to apply to the contract.
-  -> Either (ApplyInputsError v) (TxConstraints v)
+  -> Either (ApplyInputsError v) (ApplyResults v, TxConstraints v)
 buildApplyInputsConstraints systemStart eraHistory version marloweOutput invalidBefore invalidHereafter redeemer =
   case version of
     MarloweV1 -> buildApplyInputsConstraintsV1 systemStart eraHistory marloweOutput invalidBefore invalidHereafter redeemer
@@ -275,8 +277,8 @@ buildApplyInputsConstraintsV1
   -> UTCTime -- ^ The minimum bound of the validity interval (inclusive).
   -> Maybe UTCTime -- ^ The maximum bound of the validity interval (exclusive).
   -> Redeemer 'V1 -- ^ The inputs to apply to the contract.
-  -> Either (ApplyInputsError 'V1) (TxConstraints 'V1)
-buildApplyInputsConstraintsV1 systemStart eraHistory marloweOutput invalidBefore invalidHereafter redeemer = execWriterT do
+  -> Either (ApplyInputsError 'V1) (ApplyResults 'V1, TxConstraints 'V1)
+buildApplyInputsConstraintsV1 systemStart eraHistory marloweOutput invalidBefore invalidHereafter redeemer = runWriterT do
   let
     TransactionScriptOutput _ _ _ datum = marloweOutput
     V1.MarloweData params state contract = datum
@@ -321,11 +323,12 @@ buildApplyInputsConstraintsV1 systemStart eraHistory marloweOutput invalidBefore
 
   -- Construct outputs constraints.
   -- Require Marlowe output if the contract is not closed.
-  for_ possibleContinuation \(state'@V1.State { accounts }, contract') -> do
+  output <- for possibleContinuation \(state'@V1.State { accounts }, contract') -> do
       let
         datum' = V1.MarloweData params state' contract'
         assets = moneyToAssets $ V1.totalBalance accounts
       tell $ mustSendMarloweOutput assets datum'
+      pure (assets, datum')
 
   -- For every payment require an output either to the role
   -- payout script or directly to the party address.
@@ -352,6 +355,8 @@ buildApplyInputsConstraintsV1 systemStart eraHistory marloweOutput invalidBefore
       Just cont -> tell $ mustSendMerkleizedContinuationOutput cont
       Nothing -> pure ()
 
+  pure (posixTimeToUTCTime $ fst txInterval, posixTimeToUTCTime $ snd txInterval, output)
+
   where
     marloweMerkleizedContinuation (V1.NormalInput _) = Nothing
     marloweMerkleizedContinuation (V1.MerkleizedInput _ _ c) = Just c

marlowe-runtime/src/Language/Marlowe/Runtime/Transaction/Constraints.hs

@@ -374,7 +374,7 @@ solveConstraints
   -> SolveConstraints
 solveConstraints start history protocol version marloweCtx walletCtx constraints =
   solveInitialTxBodyContent protocol version marloweCtx walletCtx constraints
-    >>= adjustTxForMinUtxo protocol marloweCtx
+    >>= adjustTxForMinUtxo protocol (marloweAddress marloweCtx)
     >>= selectCoins protocol version marloweCtx walletCtx
     >>= balanceTx C.BabbageEraInCardanoMode start history protocol version marloweCtx walletCtx
 
@@ -419,10 +419,10 @@ adjustOutputForMinUtxo protocol (C.TxOut address txOrigValue datum script) = do
 adjustTxForMinUtxo
   :: forall v
    . C.ProtocolParameters
-  -> MarloweContext v
+  -> Chain.Address
   -> C.TxBodyContent C.BuildTx C.BabbageEra
   -> Either (ConstraintError v) (C.TxBodyContent C.BuildTx C.BabbageEra)
-adjustTxForMinUtxo protocol MarloweContext{..} txBodyContent = do
+adjustTxForMinUtxo protocol marloweAddress txBodyContent = do
   let
     getMarloweOutputValue :: [C.TxOut C.CtxTx C.BabbageEra] -> Maybe (C.TxOutValue C.BabbageEra)
     getMarloweOutputValue = getFirst . mconcat . map (First

marlowe-runtime/src/Language/Marlowe/Runtime/Transaction/Server.hs

@@ -20,14 +20,15 @@ import Cardano.Api
   , CardanoEra(BabbageEra)
   , CardanoMode
   , EraHistory
+  , IsCardanoEra
   , NetworkId(..)
-  , PaymentCredential(..)
   , ShelleyBasedEra(..)
   , StakeAddressReference(..)
   , Tx
   , TxBody(..)
   , TxBodyContent(..)
   , TxOut(..)
+  , cardanoEra
   , getTxBody
   , getTxId
   , makeShelleyAddress
@@ -39,7 +40,7 @@ import Control.Concurrent.Async (Concurrently(..))
 import Control.Concurrent.Component
 import Control.Concurrent.STM (STM, atomically, modifyTVar, newEmptyTMVar, newTVar, putTMVar, readTMVar, readTVar)
 import Control.Error.Util (hoistMaybe, note, noteT)
-import Control.Exception (SomeException, catch)
+import Control.Exception (Exception(displayException), SomeException, catch)
 import Control.Monad (when)
 import Control.Monad.Base (MonadBase(..))
 import Control.Monad.IO.Class (MonadIO(liftIO))
@@ -56,18 +57,26 @@ import Data.Maybe (fromJust)
 import Data.Time (UTCTime, getCurrentTime)
 import Data.Void (Void)
 import Language.Marlowe.Runtime.Cardano.Api
-  (fromCardanoAddressInEra, fromCardanoTxId, toCardanoPaymentCredential, toCardanoScriptHash, toCardanoStakeCredential)
+  (fromCardanoAddressInEra, fromCardanoTxId, toCardanoPaymentCredential, toCardanoStakeCredential)
 import Language.Marlowe.Runtime.ChainSync.Api
   (BlockHeader, ChainSyncQuery(..), Credential(..), TokenName, TransactionMetadata, TxId(..))
 import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain
 import Language.Marlowe.Runtime.Core.Api
-  (Contract, ContractId(..), MarloweVersion(MarloweV1), Payout(Payout, datum), Redeemer, withMarloweVersion)
-import Language.Marlowe.Runtime.Core.ScriptRegistry (getCurrentScripts, marloweScript)
+  ( Contract
+  , ContractId(..)
+  , MarloweVersion(MarloweV1)
+  , Payout(Payout, datum)
+  , Redeemer
+  , TransactionScriptOutput(..)
+  , withMarloweVersion
+  )
+import Language.Marlowe.Runtime.Core.ScriptRegistry (marloweScript)
 import qualified Language.Marlowe.Runtime.Core.ScriptRegistry as Registry
 import Language.Marlowe.Runtime.Transaction.Api
   ( ApplyInputsError(..)
   , ContractCreated(..)
   , CreateError(..)
+  , InputsApplied(..)
   , JobId(..)
   , MarloweTxCommand(..)
   , RoleTokensConfig
@@ -271,35 +280,29 @@ execCreate solveConstraints loadWalletContext networkId mStakeCredential version
   txBody <- except
     $ first CreateConstraintError
     $ solveConstraints version marloweContext walletContext constraints
+  let marloweScriptAddress = Constraints.marloweAddress marloweContext
   pure ContractCreated
-    { contractId = ContractId $ findMarloweOutput mCardanoStakeCredential txBody
+    { contractId = ContractId $ fromJust $ findMarloweOutput marloweAddress txBody
     , rolesCurrency
     , metadata = Chain.unTransactionMetadata metadata
     , txBody
     , marloweScriptHash = Constraints.marloweScriptHash marloweContext
-    , marloweScriptAddress = Constraints.marloweAddress marloweContext
+    , marloweScriptAddress
     , payoutScriptHash = Constraints.payoutScriptHash marloweContext
     , payoutScriptAddress = Constraints.payoutAddress marloweContext
     , version
     , datum
     , assets
     }
+
+findMarloweOutput :: forall era. IsCardanoEra era => Chain.Address -> TxBody era -> Maybe Chain.TxOutRef
+findMarloweOutput address = \case
+  body@(TxBody TxBodyContent{..}) -> fmap (Chain.TxOutRef (fromCardanoTxId $ getTxId body) . fst)
+    $ find (isToCurrentScriptAddress . snd)
+    $ zip [0..] txOuts
   where
-  findMarloweOutput mCardanoStakeCredential = \case
-    body@(TxBody TxBodyContent{..}) -> Chain.TxOutRef (fromCardanoTxId $ getTxId body)
-      $ fst
-      $ fromJust
-      $ find (isToCurrentScriptAddress . snd)
-      $ zip [0..] txOuts
-    where
-      scriptHash = fromJust
-        $ toCardanoScriptHash
-        $ marloweScript
-        $ getCurrentScripts version
-      scriptAddress = makeShelleyAddress networkId (PaymentCredentialByScript scriptHash)
-        $ maybe NoStakeAddress StakeAddressByValue mCardanoStakeCredential
-      isToCurrentScriptAddress (TxOut (AddressInEra (ShelleyAddressInEra ShelleyBasedEraBabbage) address) _ _ _) = address == scriptAddress
-      isToCurrentScriptAddress _ = False
+    isToCurrentScriptAddress (TxOut address' _ _ _) =
+      address == fromCardanoAddressInEra (cardanoEra @era) address'
 
 execApplyInputs
   :: SystemStart
@@ -313,7 +316,7 @@ execApplyInputs
   -> Maybe UTCTime
   -> Maybe UTCTime
   -> Redeemer v
-  -> WorkerM (ServerStCmd MarloweTxCommand Void (ApplyInputsError v) (TxBody BabbageEra) WorkerM ())
+  -> WorkerM (ServerStCmd MarloweTxCommand Void (ApplyInputsError v) (InputsApplied BabbageEra v) WorkerM ())
 execApplyInputs
   systemStart
   eraHistory
@@ -323,27 +326,32 @@ execApplyInputs
   version
   addresses
   contractId
-  invalidBefore
-  invalidHereafter
+  invalidBefore'
+  invalidHereafter'
   inputs = execExceptT do
     marloweContext@MarloweContext{..} <- withExceptT ApplyInputsLoadMarloweContextFailed
       $ ExceptT
       $ liftIO $ loadMarloweContext version contractId
-    invalidBefore' <- liftIO $ maybe getCurrentTime pure invalidBefore
+    invalidBefore'' <- liftIO $ maybe getCurrentTime pure invalidBefore'
     scriptOutput' <- except $ maybe (Left ScriptOutputNotFound) Right scriptOutput
-    constraints <- except $ buildApplyInputsConstraints
+    ((invalidBefore, invalidHereafter, mAssetsAndDatum), constraints) <-
+      except $ buildApplyInputsConstraints
         systemStart
         eraHistory
         version
         scriptOutput'
-        invalidBefore'
-        invalidHereafter
+        invalidBefore''
+        invalidHereafter'
         inputs
     walletContext <- liftIO $ loadWalletContext addresses
     lift . Colog.logDebug . O.renderValue . A.toJSON $ walletContext
-    except
+    txBody <- except
       $ first ApplyInputsConstraintError
       $ solveConstraints version marloweContext walletContext constraints
+    let input = scriptOutput'
+    let buildOutput (assets, datum) utxo = TransactionScriptOutput marloweAddress assets utxo datum
+    let output = buildOutput <$> mAssetsAndDatum <*> findMarloweOutput marloweAddress txBody
+    pure InputsApplied{..}
 
 execWithdraw
   :: SolveConstraints
@@ -380,13 +388,13 @@ execSubmit mkSubmitJob trackSubmitJob tx = liftIO do
   (submitJob, exVar) <- atomically do
     exVar <- newEmptyTMVar
     submitJob <- mkSubmitJob tx
-    let getExceptionStatus = Failed SubmitException <$ readTMVar exVar
+    let getExceptionStatus = Failed . SubmitException <$> readTMVar exVar
     let submitJob' = submitJob { submitJobStatus = getExceptionStatus <|> submitJobStatus submitJob }
     trackSubmitJob txId submitJob'
     pure (submitJob', exVar)
   -- Run the job in a new thread
   _ <- forkFinally (runSubmitJob submitJob) \case
-    Left ex -> atomically $ putTMVar exVar ex
+    Left ex -> atomically $ putTMVar exVar $ displayException ex
     _ -> pure ()
   -- Make a new server and run it in IO.
   hoistCmd (liftIO . atomically) <$> atomically (submitJobServerCmd (JobIdSubmit txId) submitJob)