implement buildWithdrawConstraints

marlowe-runtime/marlowe-runtime.cabal

@@ -239,6 +239,7 @@ test-suite marlowe-runtime-test
     Language.Marlowe.Runtime.History.StoreSpec
     Language.Marlowe.Runtime.History.Store.ModelSpec
     Language.Marlowe.Runtime.HistorySpec
+    Language.Marlowe.Runtime.Transaction.BuildConstraintsSpec
     Spec.Marlowe.Semantics.Arbitrary
     Spec.Marlowe.Semantics.Golden
     Spec.Marlowe.Semantics.Golden.Escrow

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

@@ -1,3 +1,6 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+
 module Language.Marlowe.Runtime.Transaction.BuildConstraints
   ( buildApplyInputsConstraints
   , buildCreateConstraints
@@ -7,10 +10,12 @@ module Language.Marlowe.Runtime.Transaction.BuildConstraints
 import qualified Data.Aeson as Aeson
 import Data.Map (Map)
 import Data.Time (UTCTime)
-import Language.Marlowe.Runtime.ChainSync.Api (Address, SlotConfig, TokenName)
-import Language.Marlowe.Runtime.Core.Api (Contract, MarloweVersion, PayoutDatum, Redeemer, TransactionScriptOutput)
+import Language.Marlowe.Runtime.ChainSync.Api (Address, AssetId, SlotConfig, TokenName)
+import Language.Marlowe.Runtime.Core.Api
+  (Contract, MarloweVersion(MarloweV1), MarloweVersionTag(V1), PayoutDatum, Redeemer, TransactionScriptOutput)
 import Language.Marlowe.Runtime.Transaction.Api (ApplyInputsError, CreateError, WithdrawError)
-import Language.Marlowe.Runtime.Transaction.Constraints (TxConstraints)
+import Language.Marlowe.Runtime.Transaction.Constraints (TxConstraints(..))
+import qualified Language.Marlowe.Runtime.Transaction.Constraints as TxConstraints
 
 -- | Creates a set of Tx constraints that are used to build a transaction that
 -- instantiates a contract.
@@ -43,4 +48,9 @@ buildWithdrawConstraints
   :: MarloweVersion v -- ^ The Marlowe version to build the transaction for.
   -> PayoutDatum v -- ^ The role token from which to withdraw funds.
   -> Either WithdrawError (TxConstraints v)
-buildWithdrawConstraints = error "not implemented"
+buildWithdrawConstraints = \case
+  MarloweV1 -> Right . buildWithdrawConstraintsV1
+  where
+    buildWithdrawConstraintsV1 :: AssetId -> TxConstraints 'V1
+    buildWithdrawConstraintsV1 =
+      TxConstraints.mustConsumePayouts <> TxConstraints.mustSpendRoleToken

marlowe-runtime/test/Language/Marlowe/Runtime/Transaction/BuildConstraintsSpec.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE DataKinds #-}
+
+module Language.Marlowe.Runtime.Transaction.BuildConstraintsSpec
+  ( spec
+  ) where
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain
+import qualified Language.Marlowe.Runtime.Core.Api as Core.Api
+import qualified Language.Marlowe.Runtime.Transaction.Api as Transaction.Api
+import qualified Language.Marlowe.Runtime.Transaction.BuildConstraints as BuildConstraints
+import Language.Marlowe.Runtime.Transaction.Constraints (TxConstraints(..))
+import qualified Language.Marlowe.Runtime.Transaction.Constraints as TxConstraints
+import Test.Hspec (Spec, shouldBe)
+import qualified Test.Hspec as Hspec
+import qualified Test.Hspec.QuickCheck as Hspec.QuickCheck
+import qualified Test.QuickCheck as QuickCheck
+
+byteStringGen :: QuickCheck.Gen ByteString
+byteStringGen = BS.pack <$> QuickCheck.arbitrary
+
+spec :: Spec
+spec = Hspec.describe "buildWithdrawConstraints" do
+  Hspec.QuickCheck.prop "implements Marlowe V1" do
+    tokenName <- Chain.TokenName <$> byteStringGen
+    policyId <- Chain.PolicyId <$> byteStringGen
+
+    let assetId :: Chain.AssetId
+        assetId = Chain.AssetId policyId tokenName
+
+        actual :: Either Transaction.Api.WithdrawError (TxConstraints 'Core.Api.V1)
+        actual = BuildConstraints.buildWithdrawConstraints Core.Api.MarloweV1 assetId
+
+        expected :: Either Transaction.Api.WithdrawError (TxConstraints 'Core.Api.V1)
+        expected = Right $ TxConstraints
+          { marloweInputConstraints = TxConstraints.MarloweInputConstraintsNone
+          , payoutInputConstraints = Set.singleton assetId
+          , roleTokenConstraints = TxConstraints.SpendRoleTokens $ Set.singleton assetId
+          , payToAddresses = Map.empty
+          , payToRoles = Map.empty
+          , marloweOutputConstraints = TxConstraints.MarloweOutputConstraintsNone
+          , signatureConstraints = Set.empty
+          , metadataConstraints = Map.empty
+          }
+
+    pure $ actual `shouldBe` expected