From 16dcb82eb9a7fbe924c686e4713b3e3c868fd585 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 10 Jul 2020 09:49:50 +0100 Subject: [PATCH] SCB: Improved formatting of active endpoint hooks. --- plutus-scb-client/src/View/Contracts.purs | 3 +- plutus-scb-client/src/View/Pretty.purs | 141 +++++++++++++++++----- web-common/src/Playground/Lenses.purs | 6 + 3 files changed, 116 insertions(+), 34 deletions(-) diff --git a/plutus-scb-client/src/View/Contracts.purs b/plutus-scb-client/src/View/Contracts.purs index 18eff4f6c38..ba758b47a57 100644 --- a/plutus-scb-client/src/View/Contracts.purs +++ b/plutus-scb-client/src/View/Contracts.purs @@ -23,6 +23,7 @@ import Plutus.SCB.Types (ContractExe) import Schema.Types (FormEvent) import Types (EndpointForm, HAction(..), WebData, _contractInstanceIdString, _contractPath, _csContract, _csCurrentState, _hooks) import Validation (_argument) +import View.Pretty (pretty) import View.Utils (webDataPane) installedContractsPane :: @@ -129,7 +130,7 @@ contractRequestView contractInstance = tr_ [ td_ [ text $ show itID ] , td_ [ text $ show rqID ] - , td_ [ text $ show rqRequest ] + , td_ [ pretty rqRequest ] ] hasActiveRequests :: forall t. ContractInstanceState t -> Boolean diff --git a/plutus-scb-client/src/View/Pretty.purs b/plutus-scb-client/src/View/Pretty.purs index 4fe984c98c5..a13af8de0ae 100644 --- a/plutus-scb-client/src/View/Pretty.purs +++ b/plutus-scb-client/src/View/Pretty.purs @@ -1,48 +1,49 @@ module View.Pretty where -import Data.Lens (toArrayOf, view) -import Halogen.HTML (HTML, b_, div_, span_, text) -import Language.Plutus.Contract.Effects.ExposeEndpoint (EndpointDescription) -import Playground.Lenses (_endpointValue, _getEndpointDescription, _txConfirmed, _txId) -import Plutus.SCB.Events (ChainEvent(..)) -import Plutus.SCB.Events.Contract (ContractEvent(..), ContractInstanceState(..), ContractResponse(..)) -import Plutus.SCB.Events.User (UserEvent(..)) -import Plutus.SCB.Types (ContractExe(..)) -import Types (_contractActiveEndpoints, _contractInstanceIdString) +import Prelude import Bootstrap (alertDanger_, nbsp) import Data.Array (length) -import Prelude +import Data.Lens (toArrayOf, view) import Data.Lens.Iso.Newtype (_Newtype) import Data.Map as Map import Data.Newtype (unwrap) +import Halogen.HTML (HTML, b_, div_, span_, text) +import Language.Plutus.Contract.Effects.ExposeEndpoint (ActiveEndpoint, EndpointDescription) import Language.Plutus.Contract.Effects.WriteTx (WriteTxResponse(..)) import Language.Plutus.Contract.Resumable (Response(..)) +import Ledger.Constraints.OffChain (UnbalancedTx(..)) import Ledger.Tx (Tx(..)) +import Playground.Lenses (_aeDescription, _endpointValue, _getEndpointDescription, _txConfirmed, _txId) +import Plutus.SCB.Events (ChainEvent(..)) +import Plutus.SCB.Events.Contract (ContractEvent(..), ContractInstanceState(..), ContractResponse(..), ContractSCBRequest(..)) import Plutus.SCB.Events.Node (NodeEvent(..)) +import Plutus.SCB.Events.User (UserEvent(..)) import Plutus.SCB.Events.Wallet (WalletEvent(..)) +import Plutus.SCB.Types (ContractExe(..)) +import Types (_contractActiveEndpoints, _contractInstanceIdString) class Pretty a where pretty :: forall p i. a -> HTML p i instance prettyChainEvent :: Pretty t => Pretty (ChainEvent t) where - pretty (ContractEvent subevent) = eventWithPrefix "Contract" $ pretty subevent - pretty (UserEvent subevent) = eventWithPrefix "User" $ pretty subevent - pretty (WalletEvent subevent) = eventWithPrefix "Wallet" $ pretty subevent - pretty (NodeEvent subevent) = eventWithPrefix "Node" $ pretty subevent + pretty (ContractEvent subevent) = withHeading "Contract" subevent + pretty (UserEvent subevent) = withHeading "User" subevent + pretty (WalletEvent subevent) = withHeading "Wallet" subevent + pretty (NodeEvent subevent) = withHeading "Node" subevent -eventWithPrefix :: forall i p. String -> HTML p i -> HTML p i -eventWithPrefix prefix content = +withHeading :: forall i p a. Pretty a => String -> a -> HTML p i +withHeading prefix content = span_ [ b_ [ text prefix , text ":" , nbsp ] - , content + , pretty content ] instance prettyUserEvent :: Pretty t => Pretty (UserEvent t) where - pretty (InstallContract contract) = span_ [ text $ "Install", nbsp, pretty contract ] + pretty (InstallContract contract) = span_ [ text $ "Install:", nbsp, pretty contract ] instance prettyContractExe :: Pretty ContractExe where pretty ((ContractExe { contractPath })) = text contractPath @@ -72,7 +73,7 @@ instance prettyContractInstanceState :: Pretty t => Pretty (ContractInstanceStat instance prettyNodeEvent :: Pretty NodeEvent where pretty event@(SubmittedTx tx) = span_ - [ text "SubmittedTx" + [ text "SubmittedTx:" , nbsp , pretty tx ] @@ -102,19 +103,19 @@ instance prettyResponse :: Pretty a => Pretty (Response a) where instance prettyContractResponse :: Pretty ContractResponse where pretty (AwaitSlotResponse slot) = span_ - [ text "AwaitSlotResponse" + [ text "AwaitSlotResponse:" , nbsp , text $ show slot ] pretty (AwaitTxConfirmedResponse txConfirmed) = span_ - [ text "AwaitTxConfirmedResponse Confirmed:" + [ text "AwaitTxConfirmedResponse:" , nbsp , text $ view (_txConfirmed <<< _txId) txConfirmed ] pretty (UserEndpointResponse endpointDescription endpointValue) = span_ - [ text "UserEndpointResponse" + [ text "UserEndpointResponse:" , nbsp , pretty endpointDescription , nbsp @@ -122,54 +123,128 @@ instance prettyContractResponse :: Pretty ContractResponse where ] pretty (OwnPubkeyResponse pubKey) = span_ - [ text "OwnPubkeyResponse" + [ text "OwnPubkeyResponse:" , nbsp , text $ show pubKey ] pretty (UtxoAtResponse utxoAtAddress) = span_ - [ text "UtxoAtResponse" + [ text "UtxoAtResponse:" , nbsp , text $ show utxoAtAddress ] pretty (NextTxAtResponse addressChangeResponse) = span_ - [ text "NextTxAtResponse" + [ text "NextTxAtResponse:" , nbsp , text $ show addressChangeResponse ] pretty (WriteTxResponse writeTxResponse) = span_ - [ text "WriteTxResponse" + [ text "WriteTxResponse:" , nbsp , pretty writeTxResponse ] +instance prettyContractSCBRequest :: Pretty ContractSCBRequest where + pretty (AwaitSlotRequest slot) = + span_ + [ text "AwaitSlotRequest:" + , nbsp + , text $ show slot + ] + pretty (AwaitTxConfirmedRequest txId) = + span_ + [ text "AwaitTxConfirmedRequest:" + , nbsp + , text $ view _txId txId + ] + pretty (UserEndpointRequest activeEndpoint) = + span_ + [ text "UserEndpointRequest:" + , nbsp + , pretty activeEndpoint + ] + pretty (OwnPubkeyRequest pubKey) = + span_ + [ text "OwnPubkeyRequest:" + , nbsp + , text $ show pubKey + ] + pretty (UtxoAtRequest utxoAtAddress) = + span_ + [ text "UtxoAtRequest:" + , nbsp + , text $ show utxoAtAddress + ] + pretty (NextTxAtRequest addressChangeRequest) = + span_ + [ text "NextTxAtRequest:" + , nbsp + , text $ show addressChangeRequest + ] + pretty (WriteTxRequest writeTxRequest) = + span_ + [ text "WriteTxRequest:" + , nbsp + , pretty writeTxRequest + ] + instance prettyWriteTxResponse :: Pretty WriteTxResponse where - pretty (WriteTxSuccess tx) = span_ [ text "WriteTxSuccess", nbsp, pretty tx ] + pretty (WriteTxSuccess tx) = span_ [ text "WriteTxSuccess:", nbsp, pretty tx ] pretty (WriteTxFailed error) = alertDanger_ - [ text "WriteTxFailed" + [ text "WriteTxFailed:" , nbsp , text $ show error ] +instance prettyUnbalancedTx :: Pretty UnbalancedTx where + pretty (UnbalancedTx { unBalancedTxTx: (Tx { txInputs, txOutputs, txSignatures }) }) = + span_ + [ text "UnbalancedTx:" + , nbsp + , withBasicPlural (length txInputs) "input" + , text ", " + , withBasicPlural (length txOutputs) "output" + , text ", " + , withBasicPlural (Map.size (unwrap txSignatures)) "signature" + , text "." + ] + instance prettyTx :: Pretty Tx where pretty (Tx { txInputs, txOutputs, txSignatures }) = span_ - [ text "Tx: " - , text $ show (length txInputs) <> " inputs, " - , text $ show (length txOutputs) <> " outputs, " - , text $ show (Map.size (unwrap txSignatures)) <> " signatures." + [ text "Tx:" + , nbsp + , withBasicPlural (length txInputs) "input" + , text ", " + , withBasicPlural (length txOutputs) "output" + , text ", " + , withBasicPlural (Map.size (unwrap txSignatures)) "signature" + , text "." ] instance prettyWalletEvent :: Pretty WalletEvent where pretty (BalancedTx tx) = span_ - [ text "BalancedTx" + [ text "BalancedTx:" , nbsp , pretty tx ] +instance prettyActiveEndpoint :: Pretty ActiveEndpoint where + pretty endpoint = pretty $ view _aeDescription endpoint + instance prettyEndpointDescription :: Pretty EndpointDescription where pretty description = text $ show $ view _getEndpointDescription description + +-- | Yes, this is dumb and only handles _most_ English words, but it's and better than saying '1 input(s)'. +-- And hey, "most English words" is still a lot of words. +withBasicPlural :: forall p i. Int -> String -> HTML p i +withBasicPlural n name = + span_ + [ text $ show n + , nbsp + , text $ name <> (if n == 1 then "" else "s") + ] diff --git a/web-common/src/Playground/Lenses.purs b/web-common/src/Playground/Lenses.purs index 2ee1e9e38e6..2705c84108e 100644 --- a/web-common/src/Playground/Lenses.purs +++ b/web-common/src/Playground/Lenses.purs @@ -46,3 +46,9 @@ _txId = _Newtype <<< prop (SProxy :: SProxy "getTxId") _utxoIndexEntries :: Lens' UtxoIndex (Map TxOutRef TxOut) _utxoIndexEntries = _UtxoIndex <<< prop (SProxy :: SProxy "getIndex") <<< _JsonMap + +_aeDescription :: forall s r a. Newtype s { aeDescription :: a | r } => Lens' s a +_aeDescription = _Newtype <<< prop (SProxy :: SProxy "aeDescription") + +_aeMetadata :: forall s r a. Newtype s { aeMetadata :: a | r } => Lens' s a +_aeMetadata = _Newtype <<< prop (SProxy :: SProxy "aeMetadata")