Skip to content

Commit

Permalink
Improve demo
Browse files Browse the repository at this point in the history
  • Loading branch information
@j-mueller
j-mueller committed Apr 6, 2021
1 parent fef4a9c commit 52d7fb9
Show file tree
Hide file tree
Showing 3 changed files with 72 additions and 74 deletions.
51 changes: 17 additions & 34 deletions plutus-pab/app/PSGenerator.hs
View file
Expand Up @@ -31,39 +31,23 @@ import Language.PureScript.Bridge.CodeGenSwitches (ForeignOptions (For
import Language.PureScript.Bridge.TypeParameters (A)
import Ledger.Constraints.OffChain (UnbalancedTx)
import qualified PSGenerator.Common
import Plutus.Contract.Checkpoint (CheckpointKey, CheckpointStore)
import Plutus.Contract.Effects.AwaitSlot (WaitingForSlot)
import Plutus.Contract.Effects.AwaitTxConfirmed (TxConfirmed)
import Plutus.Contract.Effects.ExposeEndpoint (ActiveEndpoint, EndpointValue)
import Plutus.Contract.Effects.Instance (OwnIdRequest)
import Plutus.Contract.Effects.OwnPubKey (OwnPubKeyRequest)
import Plutus.Contract.Effects.UtxoAt (UtxoAtAddress)
import Plutus.Contract.Effects.WriteTx (WriteTxResponse)
import Plutus.Contract.Resumable (Responses)
import Plutus.Contract.State (ContractRequest, State)
import Plutus.Contracts.Currency (SimpleMPS (..))
import Plutus.PAB.Core (activateContract, callContractEndpoint, installContract)
import Plutus.PAB.Effects.ContractTest (TestContracts (Currency, Game))
import Plutus.PAB.Effects.MultiAgent (agentAction)
import Plutus.PAB.Events (ChainEvent, ContractPABRequest, csContract)
import Plutus.PAB.Events.Contract (ContractEvent, ContractInstanceState, ContractResponse,
PartiallyDecodedResponse)
import Plutus.PAB.Events.Node (NodeEvent)
import Plutus.PAB.Events.User (UserEvent)
import Plutus.PAB.Events.Wallet (WalletEvent)
import Plutus.PAB.MockApp (defaultWallet)
import qualified Plutus.PAB.MockApp as MockApp
import Plutus.PAB.Types (ContractExe)
import qualified Plutus.PAB.Webserver.API as API
import qualified Plutus.PAB.Webserver.Handler as Webserver
import Plutus.PAB.Webserver.Types (ChainReport, ContractReport, ContractSignatureResponse,
FullReport, StreamToClient, StreamToServer)
import Servant.PureScript (HasBridge, Settings, _generateSubscriberAPI, apiModuleName,
defaultBridge, defaultSettings, languageBridge,
writeAPIModuleWithSettings)
import System.FilePath ((</>))
import Wallet.Effects (AddressChangeRequest (..), AddressChangeResponse (..))
import qualified Wallet.Emulator.Chain as Chain
import Plutus.PAB.Core (installContract)
import Plutus.PAB.Effects.Contract.ContractExe (ContractExe)
import Plutus.PAB.Effects.Contract.ContractTest (TestContracts (Currency, Game))
import Plutus.PAB.Events.Contract (ContractPABRequest, ContractResponse)
import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse)
import qualified Plutus.PAB.Webserver.API as API
import qualified Plutus.PAB.Webserver.Handler as Webserver
import Plutus.PAB.Webserver.Types (ChainReport, ContractReport,
ContractSignatureResponse, FullReport,
StreamToClient, StreamToServer)
import Servant.PureScript (HasBridge, Settings, _generateSubscriberAPI,
apiModuleName, defaultBridge, defaultSettings,
languageBridge, writeAPIModuleWithSettings)
import System.FilePath ((</>))
import Wallet.Effects (AddressChangeRequest (..),
AddressChangeResponse (..))
import qualified Wallet.Emulator.Chain as Chain

myBridge :: BridgePart
myBridge =
Expand Down Expand Up @@ -106,7 +90,6 @@ myTypes =
, (equal <*> (genericShow <*> mkSumType)) (Proxy @(FullReport A))
, (equal <*> (genericShow <*> mkSumType)) (Proxy @ChainReport)
, (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractReport A))
, (equal <*> (genericShow <*> mkSumType)) (Proxy @(ChainEvent A))
, (equal <*> (genericShow <*> mkSumType)) (Proxy @StreamToServer)
, (equal <*> (genericShow <*> mkSumType)) (Proxy @StreamToClient)
, (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractInstanceState A))
Expand Down
9 changes: 8 additions & 1 deletion plutus-pab/src/Plutus/PAB/Simulator.hs
View file
Expand Up @@ -306,6 +306,8 @@ runWalletState wallet = \case
let newState = s' & walletState .~ s
STM.writeTVar _agentStates (Map.insert wallet newState mp)

-- | Run an action in the context of a specific wallet, returning the error (if
-- any)
runAgentEffects ::
forall a effs.
( Member (Reader InstancesState) effs
Expand All @@ -323,6 +325,8 @@ runAgentEffects wallet action = do
result <- liftIO $ handleAgentThread state blockchainEnv inst wallet action
pure result

-- | Run an action in the context of a specific wallet. Errors are propagated
-- to the top level.
agentAction ::
forall a effs.
( Member (Reader InstancesState) effs
Expand Down Expand Up @@ -352,6 +356,7 @@ type ControlEffects effs =

type ControlThread a = Eff (ControlEffects '[IO]) a

-- | Run a
runControlEffects ::
forall a effs.
( Member (Reader InstancesState) effs
Expand Down Expand Up @@ -864,7 +869,8 @@ render :: forall a. Pretty a => a -> Text
render = Render.renderStrict . layoutPretty defaultLayoutOptions . pretty


-- | Statistics about the transactions that have been validated by the emulated node.
-- | Statistics about the transactions that have been validated by the emulated
-- node.
data TxCounts =
TxCounts
{ _txValidated :: Int
Expand All @@ -890,6 +896,7 @@ txCounts = do
, _txMemPool = length _txPool
}

-- | The set of all active contracts.
activeContracts ::
( Member (Reader InstancesState) effs
, LastMember IO effs
Expand Down
86 changes: 47 additions & 39 deletions plutus-pab/src/Plutus/PAB/Simulator/Server.hs
View file
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
Expand All @@ -18,43 +19,44 @@ module Plutus.PAB.Simulator.Server(
main
) where

import Control.Applicative (Alternative (..))
import Control.Concurrent (forkIO)
import qualified Control.Concurrent.STM as STM
import Control.Exception (SomeException, handle)
import Control.Lens (preview, (&))
import Control.Monad (guard, void)
import Control.Monad.Except (ExceptT (ExceptT))
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as JSON
import Data.Bifunctor (Bifunctor (..))
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Proxy (Proxy (..))
import GHC.Generics (Generic)
import Plutus.Contract.Effects.ExposeEndpoint (ActiveEndpoint (..))
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.WebSockets as WS
import Network.WebSockets.Connection (Connection, PendingConnection, withPingThread)
import Plutus.PAB.Core.ContractInstance.STM (OpenEndpoint (..))
import qualified Plutus.PAB.Effects.Contract as Contract
import Plutus.PAB.Effects.Contract.ContractTest (TestContracts (AtomicSwap, Currency))
import Plutus.PAB.Events.Contract (ContractPABRequest, _UserEndpointRequest)
import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse (hooks))
import Plutus.PAB.Instances ()
import Plutus.PAB.Simulator (SimRunner (..), Simulation)
import qualified Plutus.PAB.Simulator as Simulator
import Plutus.PAB.Types (PABError)
import Plutus.PAB.Webserver.API (ContractActivationArgs (..),
ContractInstanceClientState (..), NewAPI,
WalletInfo (..))
import Plutus.PAB.Webserver.Types (ContractSignatureResponse (..))
import Servant (Application, Handler, ServerT, (:<|>) ((:<|>)))
import qualified Servant as Servant
import Wallet.Emulator.Wallet (Wallet (..))
import Wallet.Types (ContractInstanceId)
import Control.Applicative (Alternative (..))
import Control.Concurrent (forkIO)
import qualified Control.Concurrent.STM as STM
import Control.Exception (SomeException, handle)
import Control.Lens (preview, (&))
import Control.Monad (guard, void)
import Control.Monad.Except (ExceptT (ExceptT))
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as JSON
import Data.Bifunctor (Bifunctor (..))
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Proxy (Proxy (..))
import GHC.Generics (Generic)
import Language.Plutus.Contract.Effects.ExposeEndpoint (ActiveEndpoint (..))
import Language.PlutusTx.Coordination.Contracts.Currency (SimpleMPS (..))
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.WebSockets as WS
import Network.WebSockets.Connection (Connection, PendingConnection, withPingThread)
import Plutus.PAB.Core.ContractInstance.STM (OpenEndpoint (..))
import qualified Plutus.PAB.Effects.Contract as Contract
import Plutus.PAB.Effects.Contract.ContractTest (TestContracts (AtomicSwap, Currency))
import Plutus.PAB.Events.Contract (ContractPABRequest, _UserEndpointRequest)
import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse (hooks))
import Plutus.PAB.Instances ()
import Plutus.PAB.Simulator (SimRunner (..), Simulation)
import qualified Plutus.PAB.Simulator as Simulator
import Plutus.PAB.Types (PABError)
import Plutus.PAB.Webserver.API (ContractActivationArgs (..),
ContractInstanceClientState (..), NewAPI,
WalletInfo (..))
import Plutus.PAB.Webserver.Types (ContractSignatureResponse (..))
import Servant (Application, Handler, ServerT, (:<|>) ((:<|>)))
import qualified Servant as Servant
import Wallet.Emulator.Wallet (Wallet (..))
import Wallet.Types (ContractInstanceId)

handler ::
(ContractActivationArgs TestContracts -> Simulation ContractInstanceId)
Expand Down Expand Up @@ -184,7 +186,13 @@ data StatusStreamToClient

main :: IO ()
main = void $ Simulator.runSimulation $ do
void $ Simulator.runAgentEffects (Wallet 1) $ Simulator.activateContract Currency
instanceId <- Simulator.agentAction (Wallet 1) $ Simulator.activateContract Currency
shutdown <- startServer 8080
_ <- liftIO $ getLine
_ <- liftIO getLine

void $ do
let endpointName = "Create native token"
monetaryPolicy = SimpleMPS{tokenName="my token", amount = 10000}
Simulator.callEndpointOnInstance instanceId endpointName monetaryPolicy
_ <- liftIO getLine
shutdown

0 comments on commit 52d7fb9

Please sign in to comment.