Integrating Marlowe Run with the PAB - part 2 (#2990)

* Starting on more PAB integration.

* Config changes.

* More work on wallet pickup workflow.

marlowe-dashboard-client/default.nix

@@ -11,7 +11,7 @@ let
 
   contractsJSON = pkgs.writeTextDir "contracts.json" (builtins.toJSON {
     marlowe = "${marlowe-app}/bin/marlowe-app";
-    walletCompanion = "${marlowe-companion-app}/bin/marlowe-app";
+    walletCompanion = "${marlowe-companion-app}/bin/marlowe-companion-app";
   });
 
   client = buildPursPackage {
@@ -33,7 +33,7 @@ let
 
   install-marlowe-contracts = pkgs.writeShellScriptBin "install-marlowe-contracts" ''
     ${plutus-pab.server-invoker}/bin/plutus-pab contracts install --path ${marlowe-app}/bin/marlowe-app
-    ${plutus-pab.server-invoker}/bin/plutus-pab contracts install --path ${marlowe-companion-app}/bin/marlowe-app
+    ${plutus-pab.server-invoker}/bin/plutus-pab contracts install --path ${marlowe-companion-app}/bin/marlowe-companion-app
   '';
 in
 {

marlowe-dashboard-client/plutus-pab.yaml

@@ -14,8 +14,7 @@ walletServerConfig:
 nodeServerConfig:
   mscBaseUrl: http://localhost:9082
   mscSocketPath: ./node-server.sock
-  mscSlotLength: 5
-  mscRandomTxInterval: 20
+  mscSlotLength: 1
   mscBlockReaper:
     brcInterval: 600
     brcBlocksToKeep: 100
@@ -38,8 +37,3 @@ signingProcessConfig:
 
 metadataServerConfig:
   mdBaseUrl: http://localhost:9085
-
-# Optional EKG Server Config
-# ----
-# monitoringConfig:
-#   monitoringPort: 9090

marlowe-dashboard-client/src/Bridge.purs

@@ -20,7 +20,6 @@ import Plutus.V1.Ledger.Crypto (PubKey(..), PubKeyHash(..)) as Back
 import Plutus.V1.Ledger.Slot (Slot(..)) as Back
 import Plutus.V1.Ledger.Value (CurrencySymbol(..), TokenName(..), Value(..)) as Back
 import PlutusTx.AssocMap (Map, fromTuples, toTuples) as Back
-import Servant.PureScript.Ajax (AjaxError)
 import Types (ContractInstanceId(..)) as Front
 import Wallet.Emulator.Wallet (Wallet(..)) as Back
 import Wallet.Types (ContractInstanceId(..)) as Back
@@ -50,7 +49,7 @@ class Bridge a b where
   toFront :: a -> b
   toBack :: b -> a
 
-instance webDataBridge :: (Bridge a b) => Bridge (RemoteData AjaxError a) (RemoteData AjaxError b) where
+instance webDataBridge :: (Bridge a b) => Bridge (RemoteData e a) (RemoteData e b) where
   toFront = map toFront
   toBack = map toBack
 
@@ -78,22 +77,22 @@ instance bigIntegerBridge :: Bridge BigInteger BigInteger where
   toFront = identity
   toBack = identity
 
--- FIXME: Marlowe.Semantics.PubKey is currently just an alias for String
+-- TODO: Marlowe.Semantics.PubKey is currently just an alias for String
 instance pubKeyBridge :: Bridge Back.PubKey String where
   toFront (Back.PubKey { getPubKey }) = getPubKey
   toBack getPubKey = Back.PubKey { getPubKey }
 
--- FIXME: the Haskell type is called 'Value' but the PureScript type is called 'Assets'
+-- TODO: the Haskell type is called 'Value' but the PureScript type is called 'Assets'
 instance valueBridge :: Bridge Back.Value Front.Assets where
   toFront (Back.Value { getValue }) = Front.Assets $ toFront getValue
   toBack (Front.Assets getValue) = Back.Value { getValue: toBack getValue }
 
--- FIXME: Marlowe.Semantics.TokenName is currently just an alias for String
+-- TODO: Marlowe.Semantics.TokenName is currently just an alias for String
 instance tokenNameBridge :: Bridge Back.TokenName String where
   toFront (Back.TokenName { unTokenName }) = unTokenName
   toBack unTokenName = Back.TokenName { unTokenName }
 
--- FIXME: Marlowe.Semantics.CurrencySymbol is currently just an alias for String
+-- TODO: Marlowe.Semantics.CurrencySymbol is currently just an alias for String
 instance currencySymbolBridge :: Bridge Back.CurrencySymbol String where
   toFront (Back.CurrencySymbol { unCurrencySymbol }) = unCurrencySymbol
   toBack unCurrencySymbol = Back.CurrencySymbol { unCurrencySymbol }

marlowe-dashboard-client/src/Capability/Contract.purs

@@ -1,7 +1,9 @@
 module Capability.Contract
-  ( class MonadContract
+  ( class ManageContract
   , activateContract
-  , getContractInstance
+  , getContractInstanceClientState
+  , getContractInstanceCurrentState
+  , getContractInstanceObservableState
   , invokeEndpoint
   , getWalletContractInstances
   , getAllContractInstances
@@ -13,38 +15,56 @@ import AppM (AppM)
 import Bridge (toFront)
 import Capability.Ajax (runAjax)
 import Control.Monad.Except (lift)
+import Data.Lens (Lens', view)
+import Data.Lens.Record (prop)
 import Data.Newtype (unwrap)
 import Data.RawJson (RawJson)
+import Data.Symbol (SProxy(..))
 import Data.UUID (toString) as UUID
 import Halogen (HalogenM)
-import MainFrame.Types (WebData)
+import Plutus.Contract.Effects.ExposeEndpoint (ActiveEndpoint)
 import Plutus.PAB.Effects.Contract.ContractExe (ContractExe)
+import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse, _PartiallyDecodedResponse)
 import Plutus.PAB.Webserver (getApiNewContractDefinitions, getApiNewContractInstanceByContractinstanceidStatus, getApiNewContractInstances, getApiNewContractInstancesWalletByWalletid, postApiNewContractActivate, postApiNewContractInstanceByContractinstanceidEndpointByEndpointname)
-import Plutus.PAB.Webserver.Types (ContractActivationArgs, ContractInstanceClientState, ContractSignatureResponse)
-import Types (ContractInstanceId)
+import Plutus.PAB.Webserver.Types (ContractActivationArgs, ContractInstanceClientState, ContractSignatureResponse, _ContractInstanceClientState)
+import Types (ContractInstanceId, WebData)
 import WalletData.Types (Wallet)
 
 -- The PAB PSGenerator (using Servant.PureScript) automatically generates a PureScript module with
--- functions for calling all PAB API endpoints. This `MonadContract` class wraps these up in a
+-- functions for calling all PAB API endpoints. This `ManageContract` class wraps these up in a
 -- 'capability' monad (https://thomashoneyman.com/guides/real-world-halogen/push-effects-to-the-edges/)
 -- with some nicer names, and mapping the result to RemoteData.
 class
-  Monad m <= MonadContract m where
+  Monad m <= ManageContract m where
   activateContract :: ContractActivationArgs ContractExe -> m (WebData ContractInstanceId)
-  getContractInstance :: ContractInstanceId -> m (WebData ContractInstanceClientState)
+  getContractInstanceClientState :: ContractInstanceId -> m (WebData ContractInstanceClientState)
+  getContractInstanceCurrentState :: ContractInstanceId -> m (WebData (PartiallyDecodedResponse ActiveEndpoint))
+  getContractInstanceObservableState :: ContractInstanceId -> m (WebData RawJson)
   invokeEndpoint :: RawJson -> ContractInstanceId -> String -> m (WebData Unit)
   getWalletContractInstances :: Wallet -> m (WebData (Array ContractInstanceClientState))
   getAllContractInstances :: m (WebData (Array ContractInstanceClientState))
   getContractDefinitions :: m (WebData (Array (ContractSignatureResponse ContractExe)))
 
-instance monadContractAppM :: MonadContract AppM where
+instance monadContractAppM :: ManageContract AppM where
   activateContract contractActivationArgs =
     runAjax
       $ map toFront
       $ postApiNewContractActivate contractActivationArgs
-  getContractInstance contractInstanceId =
+  getContractInstanceClientState contractInstanceId =
     runAjax
       $ getApiNewContractInstanceByContractinstanceidStatus (UUID.toString $ unwrap contractInstanceId)
+  getContractInstanceCurrentState contractInstanceId = do
+    clientState <- getContractInstanceClientState contractInstanceId
+    pure $ map (view _cicCurrentState) clientState
+    where
+    _cicCurrentState :: Lens' ContractInstanceClientState (PartiallyDecodedResponse ActiveEndpoint)
+    _cicCurrentState = _ContractInstanceClientState <<< prop (SProxy :: SProxy "cicCurrentState")
+  getContractInstanceObservableState contractInstanceId = do
+    currentState <- getContractInstanceCurrentState contractInstanceId
+    pure $ map (view _observableState) currentState
+    where
+    _observableState :: Lens' (PartiallyDecodedResponse ActiveEndpoint) RawJson
+    _observableState = _PartiallyDecodedResponse <<< prop (SProxy :: SProxy "observableState")
   invokeEndpoint rawJson contractInstanceId endpointDescriptionString =
     runAjax
       $ postApiNewContractInstanceByContractinstanceidEndpointByEndpointname rawJson (UUID.toString $ unwrap contractInstanceId) endpointDescriptionString
@@ -58,9 +78,11 @@ instance monadContractAppM :: MonadContract AppM where
     runAjax
       $ getApiNewContractDefinitions
 
-instance monadContractHalogenM :: MonadContract m => MonadContract (HalogenM state action slots msg m) where
+instance monadContractHalogenM :: ManageContract m => ManageContract (HalogenM state action slots msg m) where
   activateContract = lift <<< activateContract
-  getContractInstance = lift <<< getContractInstance
+  getContractInstanceClientState = lift <<< getContractInstanceClientState
+  getContractInstanceCurrentState = lift <<< getContractInstanceCurrentState
+  getContractInstanceObservableState = lift <<< getContractInstanceObservableState
   invokeEndpoint payload contractInstanceId endpointDescription = lift $ invokeEndpoint payload contractInstanceId endpointDescription
   getWalletContractInstances = lift <<< getWalletContractInstances
   getAllContractInstances = lift getAllContractInstances

marlowe-dashboard-client/src/Capability/Marlowe.purs

@@ -1,7 +1,8 @@
 module Capability.Marlowe
-  ( class MonadMarlowe
+  ( class ManageMarloweContract
   , marloweCreateWalletCompanionContract
-  --, marloweCreateContract
+  , marloweGetWalletCompanionContractObservableState
+  , marloweCreateContract
   , marloweApplyInputs
   , marloweWait
   , marloweAuto
@@ -11,43 +12,56 @@ module Capability.Marlowe
 import Prelude
 import AppM (AppM)
 import Bridge (toBack)
-import Capability.Contract (class MonadContract, activateContract, invokeEndpoint)
+import Capability.Contract (class ManageContract, activateContract, getContractInstanceObservableState, invokeEndpoint)
 import Capability.ContractExe (marloweContractExe, walletCompanionContractExe)
-import Control.Monad.Except (lift)
+import Control.Monad.Except (lift, runExcept)
+import Data.Either (Either(..))
 import Data.Map (Map)
+import Data.Newtype (unwrap)
 import Data.RawJson (RawJson(..))
+import Data.Tuple (Tuple)
 import Data.Tuple.Nested ((/\))
-import Foreign.Generic (encode)
+import Foreign.Generic (decodeJSON, encode)
 import Foreign.JSON (unsafeStringify)
 import Halogen (HalogenM)
-import MainFrame.Types (WebData)
-import Marlowe.Semantics (Contract, Input, Party, Slot)
+import Marlowe.Semantics (Contract, Input, Party, PubKey, Slot, TokenName)
+import Network.RemoteData (RemoteData(..))
 import Plutus.PAB.Webserver.Types (ContractActivationArgs(..))
-import Plutus.V1.Ledger.Crypto (PubKeyHash)
-import Plutus.V1.Ledger.Value (TokenName)
-import Types (ContractInstanceId, MarloweParams)
+import Types (DecodedWebData, ContractInstanceId, MarloweParams, MarloweData, WebData)
 import WalletData.Types (Wallet)
 
--- The `MonadMarlowe` class provides a window on the `MonadContract` class with function
+-- The `ManageMarloweContract` class provides a window on the `ManageContract` class with function
 -- calls specific to the Marlowe Plutus contract.
 class
-  MonadContract m <= MonadMarlowe m where
+  ManageContract m <= ManageMarloweContract m where
   marloweCreateWalletCompanionContract :: Wallet -> m (WebData ContractInstanceId)
-  --marloweCreateContract :: Wallet -> Map TokenName PubKeyHash -> Contract -> m (WebData ContractInstanceId)
+  marloweGetWalletCompanionContractObservableState :: ContractInstanceId -> m (DecodedWebData (Array (Tuple MarloweParams MarloweData)))
+  marloweCreateContract :: Wallet -> Map TokenName PubKey -> Contract -> m (WebData ContractInstanceId)
   marloweApplyInputs :: ContractInstanceId -> MarloweParams -> Array Input -> m (WebData Unit)
   marloweWait :: ContractInstanceId -> MarloweParams -> m (WebData Unit)
   marloweAuto :: ContractInstanceId -> MarloweParams -> Party -> Slot -> m (WebData Unit)
-  marloweRedeem :: ContractInstanceId -> MarloweParams -> TokenName -> PubKeyHash -> m (WebData Unit)
+  marloweRedeem :: ContractInstanceId -> MarloweParams -> TokenName -> PubKey -> m (WebData Unit)
 
-instance monadMarloweAppM :: MonadMarlowe AppM where
-  marloweCreateWalletCompanionContract wallet = activateContract $ ContractActivationArgs { caID: marloweContractExe, caWallet: toBack wallet }
-  --marloweCreateContract wallet roles contract = do
-  --  webContractInstanceId <- activateContract $ ContractActivationArgs { caID: marloweContractExe, caWallet: toBack wallet }
-  --  case webContractInstanceId of
-  --    Success contractInstanceId ->
-  --      invokeEndpoint ?(encodeJSON wallet roles) contractInstanceId "create"
-  --      pure webContractInstanceId
-  --    _ -> pure $ Failure ""
+instance monadMarloweAppM :: ManageMarloweContract AppM where
+  marloweCreateWalletCompanionContract wallet = activateContract $ ContractActivationArgs { caID: walletCompanionContractExe, caWallet: toBack wallet }
+  marloweGetWalletCompanionContractObservableState contractInstanceId = do
+    remoteDataObservableState <- getContractInstanceObservableState contractInstanceId
+    case remoteDataObservableState of
+      Success rawJson -> case runExcept $ decodeJSON $ unwrap rawJson of
+        Left decodingError -> pure $ Failure $ Right decodingError
+        Right observableState -> pure $ Success observableState
+      Failure ajaxError -> pure $ Failure $ Left ajaxError
+      NotAsked -> pure NotAsked
+      Loading -> pure Loading
+  marloweCreateContract wallet roles contract = do
+    webContractInstanceId <- activateContract $ ContractActivationArgs { caID: marloweContractExe, caWallet: toBack wallet }
+    case webContractInstanceId of
+      Success contractInstanceId -> do
+        let
+          rawJson = RawJson <<< unsafeStringify <<< encode $ (roles /\ contract)
+        _ <- invokeEndpoint rawJson contractInstanceId "create"
+        pure webContractInstanceId
+      _ -> pure webContractInstanceId
   marloweApplyInputs contractInstanceId params inputs =
     let
       rawJson = RawJson <<< unsafeStringify <<< encode $ (params /\ inputs)
@@ -63,15 +77,16 @@ instance monadMarloweAppM :: MonadMarlowe AppM where
       rawJson = RawJson <<< unsafeStringify <<< encode $ (params /\ party /\ slot)
     in
       invokeEndpoint rawJson contractInstanceId "auto"
-  marloweRedeem contractInstanceId params tokenName pubKeyHash =
+  marloweRedeem contractInstanceId params tokenName pubKey =
     let
-      rawJson = RawJson <<< unsafeStringify <<< encode $ (params /\ tokenName /\ pubKeyHash)
+      rawJson = RawJson <<< unsafeStringify <<< encode $ (params /\ tokenName /\ pubKey)
     in
       invokeEndpoint rawJson contractInstanceId "redeem"
 
-instance monadMarloweHalogenM :: MonadMarlowe m => MonadMarlowe (HalogenM state action slots msg m) where
+instance monadMarloweHalogenM :: ManageMarloweContract m => ManageMarloweContract (HalogenM state action slots msg m) where
   marloweCreateWalletCompanionContract = lift <<< marloweCreateWalletCompanionContract
-  --marloweCreateContract wallet roles contract = lift $ marloweCreateContract wallet roles contract
+  marloweGetWalletCompanionContractObservableState = lift <<< marloweGetWalletCompanionContractObservableState
+  marloweCreateContract wallet roles contract = lift $ marloweCreateContract wallet roles contract
   marloweApplyInputs contractInstanceId params inputs = lift $ marloweApplyInputs contractInstanceId params inputs
   marloweWait contractInstanceId params = lift $ marloweWait contractInstanceId params
   marloweAuto contractInstanceId params party slot = lift $ marloweAuto contractInstanceId params party slot

marlowe-dashboard-client/src/Capability/Wallet.purs

@@ -1,8 +1,8 @@
 module Capability.Wallet
-  ( class MonadWallet
+  ( class ManageWallet
   , createWallet
   , submitWalletTransaction
-  , getWalletPubKey
+  , getWalletInfo
   , updateWalletPaymentWithChange
   , getWalletSlot
   , getWalletTransactions
@@ -19,37 +19,37 @@ import Data.Json.JsonTuple (JsonTuple)
 import Data.Map (Map)
 import Data.Newtype (unwrap)
 import Halogen (HalogenM)
-import MainFrame.Types (WebData)
 import Marlowe.Semantics (Assets, Slot)
 import Plutus.PAB.Webserver (getWalletByWalletIdOwnoutputs, getWalletByWalletIdOwnpublickey, getWalletByWalletIdTotalfunds, getWalletByWalletIdWalletslot, postWalletByWalletIdSign, postWalletByWalletIdSubmittxn, postWalletByWalletIdUpdatepaymentwithchange, postWalletCreate)
 import Plutus.V1.Ledger.Tx (Tx, TxOutRef, TxOutTx)
+import Types (WebData)
 import Wallet.Types (Payment)
 import WalletData.Types (Wallet, WalletInfo)
 
 -- The PAB PSGenerator (using Servant.PureScript) automatically generates a PureScript module with
--- functions for calling all Wallet API endpoints. This `MonadWallet` class wraps these up in a
+-- functions for calling all Wallet API endpoints. This `ManageWallet` class wraps these up in a
 -- 'capability' monad (https://thomashoneyman.com/guides/real-world-halogen/push-effects-to-the-edges/)
 -- with some nicer names and type signatures, mapping the result to WebData.
 class
-  Monad m <= MonadWallet m where
+  Monad m <= ManageWallet m where
   createWallet :: m (WebData WalletInfo)
   submitWalletTransaction :: Tx -> Wallet -> m (WebData Unit)
-  getWalletPubKey :: Wallet -> m (WebData WalletInfo)
+  getWalletInfo :: Wallet -> m (WebData WalletInfo)
   updateWalletPaymentWithChange :: JsonTuple Assets Payment -> Wallet -> m (WebData Payment)
   getWalletSlot :: Wallet -> m (WebData Slot)
   getWalletTransactions :: Wallet -> m (WebData (Map TxOutRef TxOutTx))
   getWalletTotalFunds :: Wallet -> m (WebData Assets)
   signTransaction :: Tx -> Wallet -> m (WebData Tx)
 
-instance monadWalletAppM :: MonadWallet AppM where
+instance monadWalletAppM :: ManageWallet AppM where
   createWallet =
     runAjax
       $ map toFront
       $ postWalletCreate
   submitWalletTransaction tx wallet =
     runAjax
       $ postWalletByWalletIdSubmittxn tx (show $ unwrap wallet)
-  getWalletPubKey wallet =
+  getWalletInfo wallet =
     runAjax
       $ map toFront
       $ getWalletByWalletIdOwnpublickey (show $ unwrap wallet)
@@ -71,10 +71,10 @@ instance monadWalletAppM :: MonadWallet AppM where
     runAjax
       $ postWalletByWalletIdSign tx (show $ unwrap wallet)
 
-instance monadWalletHalogenM :: MonadWallet m => MonadWallet (HalogenM state action slots msg m) where
+instance monadWalletHalogenM :: ManageWallet m => ManageWallet (HalogenM state action slots msg m) where
   createWallet = lift createWallet
   submitWalletTransaction tx wallet = lift $ submitWalletTransaction tx wallet
-  getWalletPubKey = lift <<< getWalletPubKey
+  getWalletInfo = lift <<< getWalletInfo
   updateWalletPaymentWithChange valuePayment wallet = lift $ updateWalletPaymentWithChange valuePayment wallet
   getWalletSlot = lift <<< getWalletSlot
   getWalletTransactions = lift <<< getWalletTransactions