ContractResponse: enforce PABResp with PABReq

IntersectMBO · Aug 4, 2021 · 9422300 · 9422300
1 parent ec392d4
commit 9422300
Show file tree

Hide file tree

Showing 6 changed files with 13 additions and 26 deletions.
diff --git a/plutus-pab/src/Plutus/PAB/Core/ContractInstance.hs b/plutus-pab/src/Plutus/PAB/Core/ContractInstance.hs
@@ -315,7 +315,7 @@ updateState ::
     , MonadIO m
     , Member (Reader InstanceState) effs
     )
-    => ContractResponse Value Value Value PABReq
+    => ContractResponse Value Value PABResp PABReq
     -> Eff effs ()
 updateState ContractResponse{newState = State{observableState}, hooks} = do
     state <- ask

diff --git a/plutus-pab/src/Plutus/PAB/Effects/Contract.hs b/plutus-pab/src/Plutus/PAB/Effects/Contract.hs
@@ -63,7 +63,7 @@ class PABContract contract where
     type State contract
 
     -- | Extract the serialisable state from the contract instance state.
-    serialisableState :: Proxy contract -> State contract -> ContractResponse Value Value Value PABReq
+    serialisableState :: Proxy contract -> State contract -> ContractResponse Value Value PABResp PABReq
 
 -- | The open requests of the contract instance.
 requests :: forall contract. PABContract contract => State contract -> [Request PABReq]

diff --git a/plutus-pab/src/Plutus/PAB/Effects/Contract/Builtin.hs b/plutus-pab/src/Plutus/PAB/Effects/Contract/Builtin.hs
@@ -40,12 +40,10 @@ import           Control.Monad                                    (when)
 import           Control.Monad.Freer
 import           Control.Monad.Freer.Error                        (Error, throwError)
 import           Control.Monad.Freer.Extras.Log                   (LogMsg (..), logDebug)
-import           Data.Aeson                                       (FromJSON, Result (..), ToJSON, Value, fromJSON)
+import           Data.Aeson                                       (FromJSON, ToJSON, Value)
 import qualified Data.Aeson                                       as JSON
-import           Data.Bifunctor                                   (Bifunctor (first))
 import           Data.Foldable                                    (foldlM, traverse_)
 import           Data.Row
-import qualified Data.Text                                        as Text
 import           GHC.Generics                                     (Generic)
 import           Playground.Schema                                (endpointsToSchemas)
 import           Playground.Types                                 (FunctionSchema)
@@ -128,10 +126,9 @@ handleBuiltin = BuiltinHandler $ \case
     UpdateContract i _ state p -> case state of SomeBuiltinState s w -> updateBuiltin i s w p
     ExportSchema a             -> pure $ getSchema a
 
-getResponse :: forall a. SomeBuiltinState a -> ContractResponse Value Value Value PABReq
+getResponse :: forall a. SomeBuiltinState a -> ContractResponse Value Value PABResp PABReq
 getResponse (SomeBuiltinState s w) =
-    first JSON.toJSON
-    $ ContractState.mapE JSON.toJSON
+    ContractState.mapE JSON.toJSON
     $ ContractState.mapW JSON.toJSON
     $ ContractState.mkResponse w
     $ Emulator.instContractState
@@ -145,21 +142,12 @@ fromResponse :: forall a effs.
   )
   => ContractInstanceId
   -> SomeBuiltin
-  -> ContractResponse Value Value Value PABReq
+  -> ContractResponse Value Value PABResp PABReq
   -> Eff effs (SomeBuiltinState a)
 fromResponse cid (SomeBuiltin contract) ContractResponse{newState=State{record}} = do
   initialState <- initBuiltinSilently @effs @a cid contract
-
   let runUpdate (SomeBuiltinState oldS oldW) n = do
-        let v = snd <$> n
-            m :: Result (Response PABResp)
-            m = traverse fromJSON v
-        case m of
-          Error e      -> throwError $ AesonDecodingError
-                                      ("Couldn't decode JSON response when reconstructing state: " <> Text.pack e <> ".")
-                                      ( Text.pack $ show $ v )
-          Success resp -> updateBuiltinSilently @effs @a cid oldS oldW resp
-
+          updateBuiltinSilently @effs @a cid oldS oldW (snd <$> n)
   foldlM runUpdate initialState (responses record)
 
 initBuiltin, initBuiltinSilently ::

diff --git a/plutus-pab/src/Plutus/PAB/Events.hs b/plutus-pab/src/Plutus/PAB/Events.hs
@@ -23,14 +23,14 @@ import           Data.Aeson                 (FromJSON, ToJSON, Value)
 import           Data.Text.Prettyprint.Doc  (Pretty, pretty, (<+>))
 import           GHC.Generics               (Generic)
 import           Ledger.Tx                  (Tx, txId)
-import           Plutus.Contract.Effects    (PABReq)
+import           Plutus.Contract.Effects    (PABReq, PABResp)
 import           Plutus.Contract.State      (ContractResponse)
 import           Plutus.PAB.Webserver.Types (ContractActivationArgs)
 import           Wallet.Types               (ContractInstanceId)
 
 -- | A structure which ties together all possible event types into one parent.
 data PABEvent t =
-    UpdateContractInstanceState !(ContractActivationArgs t) !ContractInstanceId !(ContractResponse Value Value Value PABReq) -- ^ Update the state of a contract instance
+    UpdateContractInstanceState !(ContractActivationArgs t) !ContractInstanceId !(ContractResponse Value Value PABResp PABReq) -- ^ Update the state of a contract instance
     | SubmitTx !Tx -- ^ Send a transaction to the node
     | ActivateContract !(ContractActivationArgs t) !ContractInstanceId
     | StopContract !ContractInstanceId

diff --git a/plutus-pab/src/Plutus/PAB/Events/ContractInstanceState.hs b/plutus-pab/src/Plutus/PAB/Events/ContractInstanceState.hs
@@ -33,7 +33,7 @@ data PartiallyDecodedResponse v =
     deriving (Show, Eq, Generic, Functor, Foldable, Traversable)
     deriving anyclass (ToJSON, FromJSON)
 
-fromResp :: Contract.ContractResponse Value Value Value v -> PartiallyDecodedResponse v
+fromResp :: Contract.ContractResponse Value Value s v -> PartiallyDecodedResponse v
 fromResp Contract.ContractResponse{Contract.hooks, Contract.logs, Contract.err, Contract.lastLogs, Contract.newState = Contract.State{Contract.observableState}} =
     PartiallyDecodedResponse{hooks, logs, err, observableState, lastLogs}
 

diff --git a/plutus-pab/src/Plutus/PAB/Monitoring/PABLogMsg.hs b/plutus-pab/src/Plutus/PAB/Monitoring/PABLogMsg.hs
@@ -22,7 +22,6 @@ module Plutus.PAB.Monitoring.PABLogMsg(
     ) where
 
 import           Data.Aeson                       (FromJSON, ToJSON, Value)
-import qualified Data.Aeson                       as JSON
 import           Data.Text                        (Text)
 import           Data.Text.Prettyprint.Doc        (Pretty (..), colon, viaShow, (<+>))
 import           GHC.Generics                     (Generic)
@@ -35,7 +34,7 @@ import           Cardano.Node.Types               (MockServerLogMsg)
 import           Cardano.Wallet.Types             (WalletMsg)
 import           Data.Aeson.Text                  (encodeToLazyText)
 import qualified Data.Text                        as T
-import           Plutus.Contract.Effects          (PABReq)
+import           Plutus.Contract.Effects          (PABReq, PABResp)
 import           Plutus.Contract.Resumable        (Response)
 import           Plutus.Contract.State            (ContractResponse)
 import           Plutus.PAB.Core.ContractInstance (ContractInstanceMsg (..))
@@ -52,7 +51,7 @@ data AppMsg t =
     | PABMsg (PABLogMsg t)
     | AvailableContract Text
     | ContractInstances (ContractDef t) [ContractInstanceId]
-    | ContractHistoryItem ContractInstanceId (Response JSON.Value)
+    | ContractHistoryItem ContractInstanceId (Response PABResp)
     deriving stock (Generic)
 
 deriving stock instance (Show (ContractDef t)) => Show (AppMsg t)
@@ -181,7 +180,7 @@ instance Pretty (ContractDef t) => Pretty (PABMultiAgentMsg t) where
 
 data CoreMsg t =
     FindingContract ContractInstanceId
-    | FoundContract (Maybe (ContractResponse Value Value Value PABReq))
+    | FoundContract (Maybe (ContractResponse Value Value PABResp PABReq))
     deriving stock Generic
 
 deriving stock instance (Show (ContractDef t)) => Show (CoreMsg t)