Skip to content

Commit

Permalink
Merge pull request #2963 from input-output-hk/anemish/companion3
Browse files Browse the repository at this point in the history 
SCP-2024 Marlowe Companion Contract
  • Loading branch information
@nau
nau committed Apr 8, 2021
2 parents f117b1b + 6d1c282 commit cfb5474
Show file tree
Hide file tree
Showing 3 changed files with 117 additions and 38 deletions.
82 changes: 78 additions & 4 deletions marlowe/src/Language/Marlowe/Client.hs
View file
Expand Up @@ -4,6 +4,7 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
Expand All @@ -23,8 +24,10 @@

module Language.Marlowe.Client where
import Control.Lens
import Control.Monad (forM_)
import Control.Monad.Error.Lens (catching, throwing)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
Expand All @@ -33,9 +36,9 @@ import Language.Marlowe.Semantics hiding (Contract)
import qualified Language.Marlowe.Semantics as Marlowe
import Language.Marlowe.Util (extractContractRoles)
import Ledger (Address (..), CurrencySymbol, Datum (..), PubKeyHash, Slot (..),
TokenName, TxOutTx (..), ValidatorCtx (..), ValidatorHash,
mkValidatorScript, pubKeyHash, txOutDatum, txOutValue, validatorHash,
valueSpent)
TokenName, TxOut (..), TxOutTx (..), TxOutType (..), ValidatorCtx (..),
ValidatorHash, mkValidatorScript, pubKeyHash, txOutDatum, txOutValue,
txOutputs, validatorHash, valueSpent)
import Ledger.Ada (adaSymbol, adaValueOf)
import Ledger.Constraints
import qualified Ledger.Constraints as Constraints
Expand Down Expand Up @@ -64,6 +67,10 @@ type MarloweSchema =
.\/ Endpoint "auto" (MarloweParams, Party, Slot)
.\/ Endpoint "redeem" (MarloweParams, TokenName, PubKeyHash)


type MarloweCompanionSchema = BlockchainActions


data MarloweError =
StateMachineError SM.SMContractError
| TransitionError (SM.InvalidTransition MarloweData MarloweInput)
Expand Down Expand Up @@ -496,3 +503,70 @@ mkMarloweClient params = SM.mkStateMachineClient (mkMachineInstance params)

defaultTxValidationRange :: Slot
defaultTxValidationRange = 10


newtype CompanionState = CompanionState (Map MarloweParams MarloweData)
deriving (Semigroup,Monoid) via (Map MarloweParams MarloweData)

instance ToJSON CompanionState where
toJSON (CompanionState m) = toJSON $ Map.toList m

instance FromJSON CompanionState where
parseJSON v = CompanionState . Map.fromList <$> parseJSON v

{-|
Contract that monitors a user wallet for receiving a Marlowe role token.
When it sees that a Marlowe contract exists on chain with a role currency
of a token the user owns it updates its @CompanionState@
with contract's @MarloweParams@ and @MarloweData@
-}
marloweCompanionContract :: Contract CompanionState MarloweCompanionSchema MarloweError ()
marloweCompanionContract = contracts
where
contracts = do
pkh <- pubKeyHash <$> ownPubKey
let ownAddress = PubKeyAddress pkh
utxo <- utxoAt ownAddress
let txOuts = fmap (txOutTxOut . snd) $ Map.toList utxo
forM_ txOuts notifyOnNewContractRoles
cont ownAddress
cont ownAddress = do
txns <- nextTransactionsAt ownAddress
let txOuts = txns >>= txOutputs
forM_ txOuts notifyOnNewContractRoles
cont ownAddress


notifyOnNewContractRoles :: TxOut
-> Contract CompanionState MarloweCompanionSchema MarloweError ()
notifyOnNewContractRoles txout = do
let curSymbols = filterRoles txout
forM_ curSymbols $ \cs -> do
contract <- findMarloweContractsOnChainByRoleCurrency cs
case contract of
Just (params, md) -> tell $ CompanionState (Map.singleton params md)
Nothing -> pure ()


filterRoles :: TxOut -> [CurrencySymbol]
filterRoles TxOut { txOutValue, txOutType = PayToPubKey } =
let curSymbols = filter (/= adaSymbol) $ AssocMap.keys $ Val.getValue txOutValue
in curSymbols
filterRoles _ = []


findMarloweContractsOnChainByRoleCurrency
:: CurrencySymbol
-> Contract CompanionState
MarloweCompanionSchema
MarloweError
(Maybe (MarloweParams, MarloweData))
findMarloweContractsOnChainByRoleCurrency curSym = do
let params = marloweParams curSym
let client = mkMarloweClient params
maybeState <- SM.getOnChainState client
case maybeState of
Just ((st, _), _) -> do
let marloweData = tyTxOutData st
pure $ Just (params, marloweData)
Nothing -> pure Nothing
2 changes: 1 addition & 1 deletion marlowe/src/Language/Marlowe/Semantics.hs
View file
Expand Up @@ -422,7 +422,7 @@ data MarloweParams = MarloweParams {
rolePayoutValidatorHash :: ValidatorHash,
rolesCurrency :: CurrencySymbol
}
deriving stock (Show,Generic)
deriving stock (Show,Generic,P.Eq,P.Ord)
deriving anyclass (FromJSON,ToJSON)


Expand Down
71 changes: 38 additions & 33 deletions marlowe/test/Spec/Marlowe/Marlowe.hs
View file
Expand Up @@ -11,50 +11,50 @@ module Spec.Marlowe.Marlowe
)
where

import qualified Codec.CBOR.Write as Write
import qualified Codec.Serialise as Serialise
import Control.Exception (SomeException, catch)
import Control.Lens ((&), (.~))
import Control.Monad (void)
import Control.Monad.Freer (run)
import Control.Monad.Freer.Error (runError)
import Data.Default (Default (..))
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Text.Lazy (toStrict)
import Language.Marlowe.Analysis.FSSemantics
import Language.Marlowe.Client
import Language.Marlowe.Semantics
import Language.Marlowe.Util
import qualified PlutusTx.AssocMap as AssocMap
import System.IO.Unsafe (unsafePerformIO)

import Data.Aeson (decode, encode)
import Data.Aeson.Text (encodeToLazyText)
import qualified Data.ByteString as BS
import Data.Default (Default (..))
import Data.Either (isRight)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust)
import Data.Ratio ((%))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String

import qualified Codec.CBOR.Write as Write
import qualified Codec.Serialise as Serialise
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Text.Lazy (toStrict)
import Language.Haskell.Interpreter (Extension (OverloadedStrings), MonadInterpreter,
OptionVal ((:=)), as, interpret, languageExtensions,
runInterpreter, set, setImports)
import Plutus.Contract.Test hiding ((.&&.))
import qualified Plutus.Contract.Test as T
import qualified Plutus.Trace.Emulator as Trace
import PlutusTx.Lattice

import Language.Marlowe.Analysis.FSSemantics
import Language.Marlowe.Client
import Language.Marlowe.Semantics
import Language.Marlowe.Util
import Ledger hiding (Value)
import Ledger.Ada (lovelaceValueOf)
import Ledger.Constraints.TxConstraints (TxConstraints)
import Ledger.Typed.Scripts (scriptHash, validatorScript)
import qualified Ledger.Value as Val
import Plutus.Contract.Test hiding ((.&&.))
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 qualified PlutusTx.AssocMap as AssocMap
import PlutusTx.Lattice
import qualified PlutusTx.Prelude as P
import Spec.Marlowe.Common
import qualified Streaming.Prelude as S
import System.IO.Unsafe (unsafePerformIO)
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
Expand Down Expand Up @@ -144,27 +144,32 @@ trustFundTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 200) "Tr
bobPkh = pubKeyHash $ walletPubKey bob
bobHdl <- Trace.activateContractWallet bob marlowePlutusContract
aliceHdl <- Trace.activateContractWallet alice marlowePlutusContract
bobCompanionHdl <- Trace.activateContract bob marloweCompanionContract "bob companion"

Trace.callEndpoint @"create" aliceHdl
(AssocMap.fromList [("alice", alicePkh), ("bob", bobPkh)],
contract)
Trace.waitNSlots 5
CompanionState r <- _observableState . instContractState <$> Trace.getContractState bobCompanionHdl
case Map.toList r of
[] -> pure ()
(pms, _) : _ -> do

Trace.callEndpoint @"wait" bobHdl (params)
Trace.callEndpoint @"wait" bobHdl pms

Trace.callEndpoint @"apply-inputs" aliceHdl (params,
[ IChoice chId 256
, IDeposit "alice" "alice" ada 256
])
Trace.waitNSlots 17
Trace.callEndpoint @"apply-inputs" aliceHdl (pms,
[ IChoice chId 256
, IDeposit "alice" "alice" ada 256
])
Trace.waitNSlots 17

Trace.callEndpoint @"wait" aliceHdl (params)
Trace.callEndpoint @"wait" aliceHdl (pms)

Trace.callEndpoint @"apply-inputs" bobHdl (params, [INotify])
Trace.callEndpoint @"apply-inputs" bobHdl (pms, [INotify])

Trace.waitNSlots 2
Trace.callEndpoint @"redeem" bobHdl (params, "bob", bobPkh)
void $ Trace.waitNSlots 2
Trace.waitNSlots 2
Trace.callEndpoint @"redeem" bobHdl (pms, "bob", bobPkh)
void $ Trace.waitNSlots 2
where
alicePk = PK $ pubKeyHash $ walletPubKey alice
bobPk = PK $ pubKeyHash $ walletPubKey bob
Expand All @@ -180,7 +185,7 @@ trustFundTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 200) "Tr
(Slot 40) Close)
] (Slot 30) Close)
] (Slot 20) Close
(params, (_ :: TxConstraints MarloweInput MarloweData)) =
(params, _ :: TxConstraints MarloweInput MarloweData) =
let con = setupMarloweParams @MarloweSchema @MarloweError
(AssocMap.fromList [("alice", pubKeyHash $ walletPubKey alice), ("bob", pubKeyHash $ walletPubKey bob)])
contract
Expand Down

0 comments on commit cfb5474

Please sign in to comment.