Prevent wbe-unknown wallets in PAB calls

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

@@ -35,7 +35,12 @@ import Data.Either (note')
 import Data.Filterable (filterMap)
 import Data.Lens (view)
 import Data.NewContract (NewContract(..))
-import Data.PABConnectedWallet (PABConnectedWallet, _address, _marloweAppId)
+import Data.PABConnectedWallet
+  ( PABConnectedWallet
+  , _address
+  , _marloweAppId
+  , _walletId
+  )
 import Data.Tuple.Nested (type (/\), (/\))
 import Data.Variant (Variant)
 import Data.Variant.Generic (class Constructors, mkConstructors')
@@ -61,6 +66,7 @@ import Marlowe.Extended (resolveRelativeTimes, toCore)
 import Marlowe.Extended.Metadata (ContractTemplate, _extendedContract)
 import Marlowe.PAB (PlutusAppId)
 import Marlowe.Run.Server (Api) as MarloweApp
+import Marlowe.Run.Server as Marlowe
 import Marlowe.Semantics (MarloweParams, TransactionInput)
 import Marlowe.Semantics as Semantic
 import Marlowe.Template (TemplateContent(..), fillTemplate)
@@ -130,6 +136,7 @@ awaitAndHandleResult
   :: forall f m e a
    . MonadUnliftAff m
   => MonadBracket Error f m
+  => MonadAjax Marlowe.Api m
   => MonadAjax PAB.Api m
   => MonadRec m
   => PlutusAppId
@@ -192,6 +199,7 @@ instance
         { instantiateContractError, jsonAjaxError } = initializeContractError
         { nickname, roles } = params
         marloweAppId = view _marloweAppId wallet
+        walletId = view _walletId wallet
       -- To initialize a Marlowe Contract we first need to make an instance
       -- of a Core.Marlowe contract. We do this by replazing template parameters
       -- from the Extended.Marlowe template and then calling toCore. This can
@@ -203,7 +211,7 @@ instance
       -- that we can use to block and wait for the response
       reqId /\ awaitContractCreation <-
         withExceptT jsonAjaxError $ ExceptT $
-          MarloweApp.createContract marloweAppId roles contract
+          MarloweApp.createContract walletId marloweAppId roles contract
 
       -- We save in the store the request of a created contract with
       -- the information relevant to show a placeholder of a starting contract.
@@ -236,8 +244,10 @@ instance
     u <- askUnliftAff
     runExceptT do
       let marloweAppId = view _marloweAppId wallet
+      let walletId = view _walletId wallet
       awaitResult <- ExceptT
-        $ MarloweApp.applyInputs marloweAppId marloweParams transactionInput
+        $ MarloweApp.applyInputs walletId marloweAppId marloweParams
+            transactionInput
       updateStore
         $ Store.ModifySyncedContract marloweParams
         $ setPendingTransaction transactionInput
@@ -277,9 +287,10 @@ instance
       info "Redeeming payout" $ encodeJson payout
       runExceptT do
         let marloweAppId = view _marloweAppId wallet
+        let walletId = view _walletId wallet
         let address = view _address wallet
         awaitResult <- catchError
-          (ExceptT $ MarloweApp.redeem marloweAppId payout address)
+          (ExceptT $ MarloweApp.redeem walletId marloweAppId payout address)
           \err -> AVarMap.take payout redeemAvarMap *> throwError err
         lift $ awaitAndHandleResult
           marloweAppId

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

@@ -17,6 +17,7 @@ import Affjax.ResponseFormat as ResponseFormat
 import Affjax.StatusCode (StatusCode(..))
 import AppM (AppM)
 import Control.Concurrent.AVarMap as AVarMap
+import Control.Monad.Error.Class (class MonadError)
 import Control.Monad.Except (ExceptT(..), lift, runExcept, runExceptT)
 import Control.Monad.Fork.Class (class MonadBracket, bracket)
 import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
@@ -34,7 +35,7 @@ import Data.Newtype (unwrap)
 import Data.Set as Set
 import Data.String (Pattern(..), contains)
 import Data.These (theseLeft)
-import Data.Time.Duration (Milliseconds(..), Minutes(..), fromDuration)
+import Data.Time.Duration (Minutes(..), fromDuration)
 import Data.Traversable (sequence)
 import Data.UUID.Argonaut as UUID
 import Data.WalletId (WalletId)
@@ -48,6 +49,7 @@ import Foreign.Class (decode)
 import Halogen (HalogenM)
 import Halogen.Subscription as HS
 import Marlowe.PAB (PlutusAppId)
+import Marlowe.Run.Server as Marlowe
 import MarloweContract (MarloweContract)
 import Plutus.Contract.Effects (ActiveEndpoint)
 import Plutus.PAB.Webserver as PAB
@@ -67,7 +69,8 @@ class Monad m <= ManagePAB m where
   invokeEndpoint
     :: forall d
      . EncodeJson d
-    => PlutusAppId
+    => WalletId
+    -> PlutusAppId
     -> String
     -> d
     -> m (AjaxResponse Unit)
@@ -78,11 +81,41 @@ class Monad m <= ManagePAB m where
   subscribeToPlutusApp :: PlutusAppId -> m Unit
   unsubscribeFromPlutusApp :: PlutusAppId -> m Unit
 
+-- This is a hack to protect the PAB from its own poor handling of wallet
+-- backend failures. Some of our contracts perform `ownPublicKey` requests
+-- which perform wallet backend API calls. If these calls fail, the contract
+-- instance's thread dies and the instance becomes an unkillable zombie which
+-- can only be cleared by restarting the PAB and deleting the contract instance
+-- from the database.
+--
+-- The most common reason why these calls fail is because we provide a wallet
+-- ID that the wallet backend doesn't have in its database (this happens often
+-- with the in memory wallet store). The safeguard against this, we call our
+-- own `GET total-funds` endpoint which also calls the wallet backend and fails
+-- if the wallet backend does. If this call fails, we don't even try sending
+-- anything to the PAB.
+--
+-- The common case of this is starting a wallet companion before we've polled
+-- the wallet backend (e.g. when refreshing and using the locally saved wallet
+-- information to connect). This results in an apparently "active" wallet
+-- companion instance which is nonetheless dead, and never sends any updates.
+assertWalletStatus
+  :: forall m
+   . MonadAjax Marlowe.Api m
+  => MonadError Error m
+  => MonadEffect m
+  => WalletId
+  -> AppM m (AjaxResponse Unit)
+assertWalletStatus wallet = do
+  response <- Marlowe.getApiWalletV1ByWalletidTotalfunds wallet
+  pure $ void response
+
 instance
   ( MonadRec m
   , MonadAff m
   , MonadBracket Error f m
   , MonadAjax PAB.Api m
+  , MonadAjax Marlowe.Api m
   ) =>
   ManagePAB (AppM m) where
   stopContract instanceId = do
@@ -102,9 +135,13 @@ instance
     bracket
       (liftAff $ AVar.take pabAvar)
       (\_ -> liftAff <<< flip AVar.put pabAvar)
-      \_ -> do
-        liftAff $ delay $ Milliseconds 100.0
-        PAB.postApiContractActivate
+      \_ -> runExceptT do
+        -- Ugly hack to prevent the PAB getting called with a wallet ID the wallet
+        -- backend doesn't know about. This can cause zombie app instances to be
+        -- spawned.
+        ExceptT $ assertWalletStatus wallet
+
+        ExceptT $ PAB.postApiContractActivate
           $ ContractActivationArgs
               { caID: contractActivationId
               , caWallet: Just $ Wallet
@@ -113,14 +150,19 @@ instance
                   }
               }
 
-  invokeEndpoint appId endpoint payload =
+  invokeEndpoint wallet appId endpoint payload =
     runExceptT $ untilJust $ runMaybeT do
       endpointAvarMap <- asks $ view _endpointAVarMap
       -- Try to take the endpoint's availability AVar with a 5 minute timeout
       lift $ ExceptT $ liftAff $ parOneOf
         [ Right <$> AVarMap.take (Tuple appId endpoint) endpointAvarMap
         , Left timeoutError <$ delay (fromDuration $ Minutes 5.0)
         ]
+      -- Ugly hack to prevent the PAB getting called with a wallet ID the wallet
+      -- backend doesn't know about. This can cause zombie app instances to be
+      -- spawned.
+      lift $ ExceptT $ assertWalletStatus wallet
+
       ajaxResult <- lift $ lift $
         PAB.postApiContractInstanceByContractinstanceidEndpointByEndpointname
           (encodeJson payload)
@@ -162,8 +204,14 @@ instance
           _ -> false
       _ -> false
 
-  getWalletContractInstances wallet =
-    PAB.getApiContractInstancesWalletByWalletid (WalletId.toString wallet)
+  getWalletContractInstances wallet = runExceptT do
+    -- Ugly hack to prevent the PAB getting called with a wallet ID the wallet
+    -- backend doesn't know about. This can cause zombie app instances to be
+    -- spawned.
+    ExceptT $ assertWalletStatus wallet
+
+    ExceptT $ PAB.getApiContractInstancesWalletByWalletid
+      (WalletId.toString wallet)
       Nothing
 
   onNewActiveEndpoints appId endpoints = do
@@ -200,10 +248,8 @@ instance ManagePAB m => ManagePAB (HalogenM state action slots msg m) where
   activateContract contractActivationId wallet = lift $ activateContract
     contractActivationId
     wallet
-  invokeEndpoint plutusAppId endpointDescription payload = lift $ invokeEndpoint
-    plutusAppId
-    endpointDescription
-    payload
+  invokeEndpoint wallet plutusAppId endpointDescription payload = lift $
+    invokeEndpoint wallet plutusAppId endpointDescription payload
   getWalletContractInstances = lift <<< getWalletContractInstances
   onNewActiveEndpoints appId = lift <<< onNewActiveEndpoints appId
   subscribeToPlutusApp = lift <<< subscribeToPlutusApp
@@ -214,10 +260,8 @@ instance ManagePAB m => ManagePAB (MaybeT m) where
   activateContract contractActivationId wallet = lift $ activateContract
     contractActivationId
     wallet
-  invokeEndpoint plutusAppId endpointDescription payload = lift $ invokeEndpoint
-    plutusAppId
-    endpointDescription
-    payload
+  invokeEndpoint wallet plutusAppId endpointDescription payload = lift $
+    invokeEndpoint wallet plutusAppId endpointDescription payload
   getWalletContractInstances = lift <<< getWalletContractInstances
   onNewActiveEndpoints appId = lift <<< onNewActiveEndpoints appId
   subscribeToPlutusApp = lift <<< subscribeToPlutusApp
@@ -228,10 +272,8 @@ instance ManagePAB m => ManagePAB (ReaderT r m) where
   activateContract contractActivationId wallet = lift $ activateContract
     contractActivationId
     wallet
-  invokeEndpoint plutusAppId endpointDescription payload = lift $ invokeEndpoint
-    plutusAppId
-    endpointDescription
-    payload
+  invokeEndpoint wallet plutusAppId endpointDescription payload = lift $
+    invokeEndpoint wallet plutusAppId endpointDescription payload
   getWalletContractInstances = lift <<< getWalletContractInstances
   onNewActiveEndpoints appId = lift <<< onNewActiveEndpoints appId
   subscribeToPlutusApp = lift <<< subscribeToPlutusApp

marlowe-dashboard-client/src/Capability/PlutusApps/FollowerApp.purs

@@ -39,6 +39,7 @@ import Marlowe.Client (getContract)
 import Marlowe.Deinstantiate (findTemplate)
 import Marlowe.Extended.Metadata (emptyContractMetadata)
 import Marlowe.PAB (PlutusAppId)
+import Marlowe.Run.Server as Marlowe
 import Marlowe.Semantics (MarloweParams)
 import MarloweContract (MarloweContract(..))
 import Plutus.PAB.Webserver (Api) as PAB
@@ -93,6 +94,7 @@ instance
   , MonadError Error m
   , MonadBracket Error f m
   , MonadAjax PAB.Api m
+  , MonadAjax Marlowe.Api m
   ) =>
   FollowerApp (AppM m) where
   followContract wallet marloweParams =
@@ -128,7 +130,7 @@ instance
             -- Tell it to follow the Marlowe contract via its MarloweParams
             withExceptT FollowContractError
               $ ExceptT
-              $ PAB.invokeEndpoint followAppId "follow" marloweParams
+              $ PAB.invokeEndpoint walletId followAppId "follow" marloweParams
             pure followAppId
     where
     lockFollowerActivation = do

marlowe-dashboard-client/src/Capability/PlutusApps/MarloweApp.purs

@@ -31,11 +31,13 @@ import Data.Map (Map)
 import Data.Map as Map
 import Data.Tuple.Nested (type (/\), (/\))
 import Data.UUID.Argonaut (UUID)
+import Data.WalletId (WalletId)
 import Effect.Aff (Aff, Error, forkAff, joinFiber)
 import Effect.Aff.Class (class MonadAff, liftAff)
 import Env (Env, _applyInputBus, _createBus, _redeemBus)
 import Language.Marlowe.Client (MarloweError)
 import Marlowe.PAB (PlutusAppId)
+import Marlowe.Run.Server as Marlowe
 import Marlowe.Semantics
   ( Contract
   , MarloweParams
@@ -50,19 +52,22 @@ import Types (AjaxResponse)
 
 class MarloweApp m where
   createContract
-    :: PlutusAppId
+    :: WalletId
+    -> PlutusAppId
     -> Map TokenName Address
     -> Contract
     -> m (AjaxResponse (UUID /\ Aff (Either MarloweError MarloweParams)))
   applyInputs
-    :: PlutusAppId
+    :: WalletId
+    -> PlutusAppId
     -> MarloweParams
     -> TransactionInput
     -> m (AjaxResponse (Aff (Either MarloweError Unit)))
   -- TODO auto
   -- TODO close
   redeem
-    :: PlutusAppId
+    :: WalletId
+    -> PlutusAppId
     -> Payout
     -> Address
     -> m (AjaxResponse (Aff (Either MarloweError Unit)))
@@ -72,31 +77,34 @@ instance
   , MonadAff m
   , MonadRec m
   , MonadAjax PAB.Api m
+  , MonadAjax Marlowe.Api m
   , MonadUUID m
   ) =>
   MarloweApp (AppM m) where
-  createContract marloweAppId roles contract =
-    invokeMarloweAppEndpoint _createBus marloweAppId "create"
+  createContract walletId marloweAppId roles contract =
+    invokeMarloweAppEndpoint walletId _createBus marloweAppId "create"
       [ encodeJson
           $ Map.fromFoldable
           $ map (lmap { unTokenName: _ })
           $ (Map.toUnfoldable roles :: Array _)
       , encodeJson contract
       ]
 
-  applyInputs marloweAppId marloweParams input = do
+  applyInputs walletId marloweAppId marloweParams input = do
     let
       TransactionInput { interval, inputs } = input
       TimeInterval invalidBefore invalidHereafter = interval
       endpoint = "apply-inputs-nonmerkleized"
-    map snd <$> invokeMarloweAppEndpoint _applyInputBus marloweAppId endpoint
+    map snd <$> invokeMarloweAppEndpoint walletId _applyInputBus marloweAppId
+      endpoint
       [ encodeJson marloweParams
       , encodeJson $ invalidBefore /\ invalidHereafter
       , encodeJson inputs
       ]
 
-  redeem marloweAppId { marloweParams, tokenName } address =
-    map snd <$> invokeMarloweAppEndpoint _redeemBus marloweAppId "redeem"
+  redeem walletId marloweAppId { marloweParams, tokenName } address =
+    map snd <$> invokeMarloweAppEndpoint walletId _redeemBus marloweAppId
+      "redeem"
       [ encodeJson marloweParams
       , encodeJson { unTokenName: tokenName }
       , encodeJson address
@@ -107,14 +115,16 @@ invokeMarloweAppEndpoint
    . MonadUUID m
   => MonadAff m
   => MonadRec m
+  => MonadAjax Marlowe.Api m
   => MonadAjax PAB.Api m
   => MonadBracket Error f m
-  => Lens' Env (EventBus UUID a)
+  => WalletId
+  -> Lens' Env (EventBus UUID a)
   -> PlutusAppId
   -> String
   -> Array Json
   -> AppM m (AjaxResponse (Tuple UUID (Aff a)))
-invokeMarloweAppEndpoint busLens marloweAppId endpoint payload =
+invokeMarloweAppEndpoint walletId busLens marloweAppId endpoint payload =
   runExceptT do
     reqId <- lift generateUUID
     bus <- asks $ view busLens
@@ -123,6 +133,6 @@ invokeMarloweAppEndpoint busLens marloweAppId endpoint payload =
     -- can even subscribe to the event bus.
     responseFiber <-
       liftAff $ forkAff $ EventBus.subscribeOnce bus.emitter reqId
-    ExceptT $ PAB.invokeEndpoint marloweAppId endpoint $ encodeJson reqId :
-      payload
+    ExceptT $ PAB.invokeEndpoint walletId marloweAppId endpoint
+      $ encodeJson reqId : payload
     pure $ Tuple reqId $ joinFiber responseFiber