Merge pull request #360 from input-output-hk/scp-4704-post-contracts

SCP-4704 POST /contracts

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

@@ -5,13 +5,12 @@ module Language.Marlowe.Runtime.CLI.Command.Create
   where
 
 import qualified Cardano.Api as C
-import Control.Error (MaybeT(MaybeT, runMaybeT))
 import Control.Error.Util (hoistMaybe, noteT)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except (ExceptT(ExceptT), throwE)
 import Data.Aeson (toJSON)
 import qualified Data.Aeson as A
-import Data.Bifunctor (Bifunctor(first, second))
+import Data.Bifunctor (first)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -38,7 +37,8 @@ import Language.Marlowe.Runtime.Core.Api
   , MarloweVersionTag(V1)
   , SomeMarloweVersion(SomeMarloweVersion)
   )
-import Language.Marlowe.Runtime.Transaction.Api (CreateError, MarloweTxCommand(Create), Mint, mkMint)
+import Language.Marlowe.Runtime.Transaction.Api
+  (ContractCreated(..), CreateError, MarloweTxCommand(Create), RoleTokensConfig(..), mkMint)
 import Options.Applicative
 import Options.Applicative.NonEmpty (some1)
 import Text.Read (readMaybe)
@@ -154,15 +154,13 @@ createCommandParser = info (txCommandParser parser) $ progDesc "Create a new Mar
 runCreateCommand :: TxCommand CreateCommand -> CLI ()
 runCreateCommand TxCommand { walletAddresses, signingMethod, metadataFile, subCommand=CreateCommand{..}} = case marloweVersion of
   SomeMarloweVersion MarloweV1 -> runCLIExceptT do
-    minting' <- runMaybeT do
-      roles' <- MaybeT $ pure roles
-      case roles' of
-        MintSimple tokens -> do
-          let
-            toNFT addr = (addr, Left 1)
-          pure $ Right . mkMint . fmap (second toNFT) $ tokens
-        UseExistingPolicyId policyId -> pure . Left $ policyId
-        MintConfig _ -> MaybeT $ throwE (RolesConfigNotSupportedYet roles')
+    minting' <- case roles of
+      Nothing -> pure RoleTokensNone
+      Just (MintSimple tokens) -> do
+        let toNFT addr = (addr, Left 1)
+        pure $ RoleTokensMint $ mkMint $ fmap toNFT <$> tokens
+      Just (UseExistingPolicyId policyId) -> pure $ RoleTokensUsePolicy policyId
+      Just roles'@(MintConfig _) -> throwE (RolesConfigNotSupportedYet roles')
     ContractId contractId <- run MarloweV1 minting'
     liftIO . print $ A.encode (A.object [("contractId", toJSON . renderTxOutRef $ contractId)])
   where
@@ -181,15 +179,14 @@ runCreateCommand TxCommand { walletAddresses, signingMethod, metadataFile, subCo
         noteT (MetadataDecodingFailed Nothing) $ hoistMaybe (fromJSONEncodedTransactionMetadata metadataJSON)
       Nothing -> pure mempty
 
-    run :: MarloweVersion v -> Maybe (Either PolicyId Mint) -> ExceptT (CreateCommandError v) CLI ContractId
+    run :: MarloweVersion v -> RoleTokensConfig -> ExceptT (CreateCommandError v) CLI ContractId
     run version rolesDistribution  = do
       contract <- readContract version
       metadata <- readMetadata
       let
         cmd = Create Nothing version walletAddresses rolesDistribution metadata minUTxO contract
-      (contractId, transaction) <- ExceptT $ first CreateFailed <$> runTxCommand cmd
+      ContractCreated{contractId,txBody} <- ExceptT $ first CreateFailed <$> runTxCommand cmd
       case signingMethod of
         Manual outputFile -> do
-          ExceptT $ liftIO $ first TransactionFileWriteFailed <$> C.writeFileTextEnvelope outputFile Nothing transaction
+          ExceptT $ liftIO $ first TransactionFileWriteFailed <$> C.writeFileTextEnvelope outputFile Nothing txBody
           pure contractId
-

marlowe-runtime/marlowe-runtime.cabal

@@ -182,6 +182,7 @@ library web
     , lens
     , marlowe
     , marlowe-runtime
+    , network-uri
     , openapi3
     , servant
     , servant-pagination
@@ -204,6 +205,7 @@ library web-server
     Language.Marlowe.Runtime.Web.Server.REST
     Language.Marlowe.Runtime.Web.Server.REST.Contracts
     Language.Marlowe.Runtime.Web.Server.REST.Transactions
+    Language.Marlowe.Runtime.Web.Server.TxClient
   build-depends:
       base >= 4.9 && < 5
     , aeson
@@ -481,12 +483,14 @@ test-suite web-server-test
     , aeson
     , bytestring
     , hspec
+    , network-arbitrary
     , marlowe
     , marlowe-runtime:web
     , marlowe-runtime:web-server
     , marlowe-test
     , openapi3
     , QuickCheck
+    , quickcheck-instances
     , regex-posix
     , servant-openapi3
     , text

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

@@ -9,13 +9,15 @@
 module Language.Marlowe.Runtime.Transaction.Api
   ( ApplyInputsConstraintsBuildupError(..)
   , ApplyInputsError(..)
+  , ContractCreated(..)
   , CreateBuildupError(..)
   , CreateError(..)
   , JobId(..)
   , LoadMarloweContextError(..)
   , MarloweTxCommand(..)
   , Mint(unMint)
   , NFTMetadata(unNFTMetadata)
+  , RoleTokensConfig(..)
   , SubmitError(..)
   , SubmitStatus(..)
   , WalletAddresses(..)
@@ -24,17 +26,7 @@ module Language.Marlowe.Runtime.Transaction.Api
   , mkNFTMetadata
   ) where
 
-import Cardano.Api
-  ( AsType(..)
-  , BabbageEra
-  , SerialiseAsRawBytes(serialiseToRawBytes)
-  , Tx
-  , TxBody
-  , deserialiseFromCBOR
-  , deserialiseFromRawBytes
-  , serialiseToCBOR
-  )
-import Cardano.Api.Shelley (StakeCredential(..))
+import Cardano.Api (AsType(..), BabbageEra, IsCardanoEra, Tx, TxBody, cardanoEra, deserialiseFromCBOR, serialiseToCBOR)
 import Data.Binary (Binary, Get, get, getWord8, put)
 import Data.Binary.Put (Put, putWord8)
 import Data.ByteString (ByteString)
@@ -46,16 +38,20 @@ import Data.Set (Set)
 import Data.Time (UTCTime)
 import Data.Type.Equality (type (:~:)(Refl))
 import Data.Void (Void, absurd)
+import Data.Word (Word64)
 import GHC.Generics (Generic)
 import GHC.Natural (Natural)
+import Language.Marlowe.Runtime.Cardano.Api (cardanoEraToAsType)
 import Language.Marlowe.Runtime.ChainSync.Api
   ( Address
+  , Assets
   , BlockHeader
   , Lovelace
   , Metadata
   , PlutusScript
   , PolicyId
   , ScriptHash
+  , StakeCredential
   , TokenName
   , TransactionMetadata
   , TxId
@@ -69,7 +65,7 @@ import Network.Protocol.Job.Types (Command(..), SomeTag(..))
 
 -- CIP-25 metadata
 newtype NFTMetadata = NFTMetadata { unNFTMetadata :: Metadata }
-  deriving stock (Eq, Ord, Generic)
+  deriving stock (Show, Eq, Ord, Generic)
   deriving newtype (Binary)
 
 -- FIXME: Validate the metadata format
@@ -78,12 +74,62 @@ mkNFTMetadata = Just . NFTMetadata
 
 -- | Non empty mint request.
 newtype Mint = Mint { unMint :: Map TokenName (Address, Either Natural (Maybe NFTMetadata)) }
-  deriving stock (Eq, Ord, Generic)
+  deriving stock (Show, Eq, Ord, Generic)
   deriving newtype (Binary, Semigroup, Monoid)
 
 mkMint :: NonEmpty (TokenName, (Address, Either Natural (Maybe NFTMetadata))) -> Mint
 mkMint = Mint . Map.fromList . NonEmpty.toList
 
+data RoleTokensConfig
+  = RoleTokensNone
+  | RoleTokensUsePolicy PolicyId
+  | RoleTokensMint Mint
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (Binary)
+
+data ContractCreated era v = ContractCreated
+  { contractId :: ContractId
+  , rolesCurrency :: PolicyId
+  , metadata :: Map Word64 Metadata
+  , marloweScriptHash :: ScriptHash
+  , marloweScriptAddress :: Address
+  , payoutScriptHash :: ScriptHash
+  , payoutScriptAddress :: Address
+  , version :: MarloweVersion v
+  , datum :: Datum v
+  , assets :: Assets
+  , txBody :: TxBody era
+  }
+
+deriving instance Show (ContractCreated BabbageEra 'V1)
+deriving instance Eq (ContractCreated BabbageEra 'V1)
+
+instance IsCardanoEra era => Binary (ContractCreated era 'V1) where
+  put ContractCreated{..} = do
+    put contractId
+    put rolesCurrency
+    put metadata
+    put marloweScriptHash
+    put marloweScriptAddress
+    put payoutScriptHash
+    put payoutScriptAddress
+    putDatum MarloweV1 datum
+    put assets
+    putTxBody txBody
+  get = do
+    contractId <- get
+    rolesCurrency <- get
+    metadata <- get
+    marloweScriptHash <- get
+    marloweScriptAddress <- get
+    payoutScriptHash <- get
+    payoutScriptAddress <- get
+    datum <- getDatum MarloweV1
+    assets <- get
+    txBody <- getTxBody
+    let version = MarloweV1
+    pure ContractCreated{..}
+
 -- | 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
@@ -97,18 +143,15 @@ data MarloweTxCommand status err result where
     -- ^ The Marlowe version to use
     -> WalletAddresses
     -- ^ The wallet addresses to use when constructing the transaction
-    -> Maybe (Either PolicyId Mint)
-    -- ^ The initial distribution of role tokens
+    -> RoleTokensConfig
+    -- ^ How to initialize role tokens
     -> TransactionMetadata
     -- ^ Optional metadata to attach to the transaction
     -> Lovelace
     -- ^ Min Lovelace which should be used for the contract output.
     -> Contract v
     -- ^ The contract to run
-    -> MarloweTxCommand Void (CreateError v)
-        ( ContractId -- The ID of the contract (tx output that carries the datum)
-        , TxBody BabbageEra -- The unsigned tx body, to be signed by a wallet.
-        )
+    -> MarloweTxCommand Void (CreateError v) (ContractCreated BabbageEra v)
 
   -- | Construct a transaction that advances an active Marlowe contract by
   -- applying a sequence of inputs. The resulting, unsigned transaction can be
@@ -162,7 +205,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) (ContractId, TxBody BabbageEra)
+    TagCreate :: MarloweVersion v -> Tag MarloweTxCommand Void (CreateError v) (ContractCreated BabbageEra v)
     TagApplyInputs :: MarloweVersion v -> Tag MarloweTxCommand Void (ApplyInputsError v) (TxBody BabbageEra)
     TagWithdraw :: MarloweVersion v -> Tag MarloweTxCommand Void (WithdrawError v) (TxBody BabbageEra)
     TagSubmit :: Tag MarloweTxCommand SubmitStatus SubmitError BlockHeader
@@ -221,17 +264,7 @@ instance Command MarloweTxCommand where
 
   putCommand = \case
     Create mStakeCredential version walletAddresses roles metadata minAda contract -> do
-      case mStakeCredential of
-        Nothing -> putWord8 0x01
-        Just credential -> do
-          putWord8 0x02
-          case credential of
-            StakeCredentialByKey stakeKeyHash -> do
-              putWord8 0x01
-              put $ serialiseToRawBytes stakeKeyHash
-            StakeCredentialByScript scriptHash -> do
-              putWord8 0x02
-              put $ serialiseToRawBytes scriptHash
+      put mStakeCredential
       put walletAddresses
       put roles
       put metadata
@@ -251,24 +284,7 @@ instance Command MarloweTxCommand where
 
   getCommand = \case
     TagCreate version -> do
-      mStakeCredentialTag <- getWord8
-      mStakeCredential <- case mStakeCredentialTag of
-        0x01 -> pure Nothing
-        0x02 -> Just <$> do
-          stakeCredentialTag <- getWord8
-          case stakeCredentialTag  of
-            0x01 -> do
-              bytes <- get
-              case deserialiseFromRawBytes (AsHash AsStakeKey) bytes of
-                Nothing -> fail "invalid stake key hash bytes"
-                Just stakeKeyHash -> pure $ StakeCredentialByKey stakeKeyHash
-            0x02 -> do
-              bytes <- get
-              case deserialiseFromRawBytes AsScriptHash bytes of
-                Nothing -> fail "invalid stake key hash bytes"
-                Just scriptHash -> pure $ StakeCredentialByScript scriptHash
-            _ -> fail $ "Invalid stake credential tag " <> show stakeCredentialTag
-        _ -> fail $ "Invalid Maybe tag " <> show mStakeCredentialTag
+      mStakeCredential <- get
       walletAddresses <- get
       roles <- get
       metadata <- get
@@ -327,24 +343,24 @@ instance Command MarloweTxCommand where
     TagSubmit -> get
 
   putResult = \case
-    TagCreate _ -> \(contractId, txBody) -> put contractId *> putTxBody txBody
+    TagCreate MarloweV1 -> put
     TagApplyInputs _ -> putTxBody
     TagWithdraw _ -> putTxBody
     TagSubmit -> put
 
   getResult = \case
-    TagCreate _ -> (,) <$> get <*> getTxBody
+    TagCreate MarloweV1 -> get
     TagApplyInputs _ -> getTxBody
     TagWithdraw _ -> getTxBody
     TagSubmit -> get
 
-putTxBody :: TxBody BabbageEra -> Put
+putTxBody :: IsCardanoEra era => TxBody era -> Put
 putTxBody = put . serialiseToCBOR
 
-getTxBody :: Get (TxBody BabbageEra)
+getTxBody :: forall era. IsCardanoEra era => Get (TxBody era)
 getTxBody = do
   bytes <- get @ByteString
-  case deserialiseFromCBOR (AsTxBody AsBabbage) bytes of
+  case deserialiseFromCBOR (AsTxBody $ cardanoEraToAsType $ cardanoEra @era) bytes of
     Left err     -> fail $ show err
     Right txBody -> pure txBody
 
@@ -359,6 +375,7 @@ data CreateError v
   = CreateConstraintError (ConstraintError v)
   | CreateLoadMarloweContextFailed LoadMarloweContextError
   | CreateBuildupFailed CreateBuildupError
+  | CreateToCardanoError
   deriving (Generic)
 
 data CreateBuildupError