From 964fb73b3f6fcbdfa83ba480b036577298232c1c Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Tue, 14 Jul 2020 11:42:29 +0100 Subject: [PATCH] WIP: SCB: Improved visual feedback as websockets data is being refreshed. --- plutus-scb-client/src/MainFrame.purs | 55 ++--- plutus-scb-client/src/Network/StreamData.purs | 205 ++++++++++++++++++ plutus-scb-client/src/Types.purs | 27 ++- plutus-scb-client/src/View.purs | 81 ++++--- plutus-scb-client/src/View/Contracts.purs | 110 +++++----- plutus-scb-client/src/View/Utils.purs | 79 ++++++- plutus-scb-client/static/main.scss | 35 +++ .../src/Plutus/SCB/Webserver/Handler.hs | 6 + .../src/Plutus/SCB/Webserver/WebSocket.hs | 52 +++-- 9 files changed, 500 insertions(+), 150 deletions(-) create mode 100644 plutus-scb-client/src/Network/StreamData.purs diff --git a/plutus-scb-client/src/MainFrame.purs b/plutus-scb-client/src/MainFrame.purs index 8ef88ab403f..44eab5be17f 100644 --- a/plutus-scb-client/src/MainFrame.purs +++ b/plutus-scb-client/src/MainFrame.purs @@ -15,6 +15,7 @@ import Control.Monad.Reader (runReaderT) import Control.Monad.State (class MonadState) import Control.Monad.State.Extra (zoomStateT) import Data.Array (filter, find) +import Data.Bifunctor (lmap) import Data.Either (Either(..)) import Data.Lens (_1, _2, assign, modifying, to, use, view) import Data.Lens.At (at) @@ -37,8 +38,9 @@ import Ledger.Ada (Ada(..)) import Ledger.Extra (adaToValue) import Ledger.Value (Value) import MonadApp (class MonadApp, activateContract, getFullReport, invokeEndpoint, log, runHalogenApp) -import Network.RemoteData (RemoteData(..), _Success) +import Network.RemoteData (RemoteData(..)) import Network.RemoteData as RemoteData +import Network.StreamData as Stream import Playground.Lenses (_endpointDescription, _schema) import Playground.Types (FunctionSchema(..), _FunctionSchema) import Plutus.SCB.Events.Contract (ContractInstanceState(..)) @@ -50,7 +52,7 @@ import Schema (FormSchema) import Schema.Types (formArgumentToJson, toArgument) import Schema.Types as Schema import Servant.PureScript.Settings (SPSettings_, defaultSettings) -import Types (EndpointForm, HAction(..), Output, Query(..), State(..), View(..), WebData, _annotatedBlockchain, _chainReport, _chainState, _contractActiveEndpoints, _contractReport, _contractSignatures, _contractStates, _crActiveContractStates, _crAvailableContracts, _csContract, _csCurrentState, _currentView, _events, _webSocketMessage) +import Types (ContractSignatures, EndpointForm, HAction(..), Output, Query(..), State(..), StreamError(..), View(..), WebStreamData, _annotatedBlockchain, _chainReport, _chainState, _contractActiveEndpoints, _contractReport, _contractSignatures, _contractStates, _crActiveContractStates, _crAvailableContracts, _csContract, _csCurrentState, _currentView, _events, _webSocketMessage, fromWebData) import Validation (_argument) import View as View import WebSocket.Support as WS @@ -62,12 +64,12 @@ initialState :: State initialState = State { currentView: ActiveContracts - , contractSignatures: NotAsked + , contractSignatures: Stream.NotAsked , chainReport: NotAsked , events: NotAsked , chainState: Chain.initialState , contractStates: Map.empty - , webSocketMessage: NotAsked + , webSocketMessage: Stream.NotAsked } ------------------------------------------------------------ @@ -103,15 +105,15 @@ handleQuery :: Query a -> m (Maybe a) handleQuery (ReceiveWebSocketMessage (WS.ReceiveMessage msg) next) = do case msg of - Right (NewChainReport report) -> assign (_chainReport <<< _Success) report + Right (NewChainReport report) -> assign (_chainReport <<< RemoteData._Success) report Right (NewContractReport report) -> do - assign (_contractSignatures <<< _Success) (view _crAvailableContracts report) + assign (_contractSignatures <<< Stream._Success) (view _crAvailableContracts report) traverse_ updateFormsForContractInstance (view _crActiveContractStates report) - Right (NewChainEvents events) -> assign (_events <<< _Success) events - Right (ErrorResponse _) -> pure unit - Left err -> pure unit - assign _webSocketMessage $ RemoteData.fromEither msg + Right (NewChainEvents events) -> assign (_events <<< RemoteData._Success) events + Right (ErrorResponse err) -> pure unit + Left err -> assign _webSocketMessage $ Stream.Failure $ DecodingError err + assign _webSocketMessage $ lmap DecodingError $ Stream.fromEither msg pure $ Just next handleQuery (ReceiveWebSocketMessage WS.WebSocketClosed next) = do @@ -141,14 +143,15 @@ handleAction LoadFullReport = do (view (_contractReport <<< _crActiveContractStates) report) ) where - assignFullReportData v = do - assign _contractSignatures (view (_contractReport <<< _crAvailableContracts) <$> v) - assign _chainReport (view _chainReport <$> v) - assign _events (view _events <$> v) + assignFullReportData value = do + assign _contractSignatures + (fromWebData (view (_contractReport <<< _crAvailableContracts) <$> value)) + assign _chainReport (view _chainReport <$> value) + assign _events (view _events <$> value) handleAction (ChainAction subaction) = do mAnnotatedBlockchain <- - peruse (_chainReport <<< _Success <<< _annotatedBlockchain <<< to AnnotatedBlockchain) + peruse (_chainReport <<< RemoteData._Success <<< _annotatedBlockchain <<< to AnnotatedBlockchain) let wrapper :: Warn (Text "The question, 'Should we animate this?' feels like it belongs in the Chain module. Not here.") => @@ -164,7 +167,7 @@ handleAction (ChangeContractEndpointCall contractInstanceId endpointIndex subact modifying ( _contractStates <<< ix contractInstanceId - <<< _Success + <<< Stream._Success <<< _2 <<< ix endpointIndex <<< _argument @@ -180,7 +183,7 @@ handleAction (InvokeContractEndpoint contractInstanceId endpointForm) = do encodedForm = RawJson <<< encodeJSON <$> formArgumentToJson (view _argument endpointForm) for_ encodedForm $ \argument -> do - assign (_contractStates <<< at contractInstanceId) (Just Loading) + assign (_contractStates <<< at contractInstanceId) (Just Stream.Loading) invokeEndpoint argument contractInstanceId endpointDescription updateFormsForContractInstance :: @@ -194,28 +197,26 @@ updateFormsForContractInstance newContractInstance = do peruse ( _contractStates <<< ix csContractId - <<< _Success + <<< Stream._Success <<< _1 ) when (oldContractInstance /= Just newContractInstance) $ do - contractSignatures <- use _contractSignatures + contractSignatures :: WebStreamData ContractSignatures <- use _contractSignatures let - newForms :: Maybe (WebData (Array EndpointForm)) + newForms :: Maybe (WebStreamData (Array EndpointForm)) newForms = sequence $ createNewEndpointForms <$> contractSignatures <*> pure newContractInstance assign (_contractStates <<< at csContractId) (map (Tuple newContractInstance) <$> newForms) createNewEndpointForms :: - Array (ContractSignatureResponse ContractExe) -> + ContractSignatures -> ContractInstanceState ContractExe -> Maybe (Array EndpointForm) -createNewEndpointForms contractSignatures instanceState = - let - matchingSignature :: Maybe (ContractSignatureResponse ContractExe) - matchingSignature = getMatchingSignature instanceState contractSignatures - in - createEndpointForms instanceState <$> matchingSignature +createNewEndpointForms contractSignatures instanceState = createEndpointForms instanceState <$> matchingSignature + where + matchingSignature :: Maybe (ContractSignatureResponse ContractExe) + matchingSignature = getMatchingSignature instanceState contractSignatures createEndpointForms :: forall t. diff --git a/plutus-scb-client/src/Network/StreamData.purs b/plutus-scb-client/src/Network/StreamData.purs new file mode 100644 index 00000000000..c5084e7eaa4 --- /dev/null +++ b/plutus-scb-client/src/Network/StreamData.purs @@ -0,0 +1,205 @@ +module Network.StreamData where + +import Prelude +import Control.Monad.Error.Class (class MonadError, class MonadThrow) +import Data.Bifunctor (class Bifunctor) +import Data.Bitraversable (class Bifoldable, class Bitraversable, bifoldlDefault, bifoldrDefault, bisequenceDefault) +import Data.Either (Either(..)) +import Data.Generic.Rep (class Generic) +import Data.Lens (Prism', prism) +import Data.Traversable (class Foldable, class Traversable, foldlDefault, foldrDefault, sequenceDefault) +import Network.RemoteData (RemoteData) +import Network.RemoteData as Remote + +data StreamData e a + = NotAsked + | Loading + | Failure e + | Success a + | Refreshing a + +derive instance genericStreamData :: Generic (StreamData e a) _ + +derive instance eqStreamData :: (Eq e, Eq a) => Eq (StreamData e a) + +derive instance functorStreamData :: Functor (StreamData e) + +instance showStreamData :: (Show e, Show a) => Show (StreamData e a) where + show NotAsked = "StreamData.NotAsked" + show Loading = "StreamData.Loading" + show (Failure err) = "StreamData.Failure " <> show err + show (Success value) = "StreamData.Success " <> show value + show (Refreshing value) = "StreamData.Refreshing " <> show value + +-- | Maps functions to the `Failure` and `Success` values. +instance bifunctorStreamData :: Bifunctor StreamData where + bimap _ _ NotAsked = NotAsked + bimap _ _ Loading = Loading + bimap f _ (Failure err) = Failure (f err) + bimap _ g (Success value) = Success (g value) + bimap _ g (Refreshing value) = Refreshing (g value) + +-- | If both values are `Success`, the result is `Success`. +-- | If one is `Success` and the other is `Refreshing`, the result is `Refreshing`. +-- | If both are `Refreshing`, the result is `Refreshing`. +-- | If both are `Failure`, the first failure is returned. +instance applyStreamData :: Apply (StreamData e) where + apply (Success f) (Success value) = Success (f value) + apply (Refreshing f) (Success value) = Refreshing (f value) + apply (Success f) (Refreshing value) = Refreshing (f value) + apply (Refreshing f) (Refreshing value) = Refreshing (f value) + apply (Failure err) _ = Failure err + apply _ (Failure err) = Failure err + apply NotAsked _ = NotAsked + apply _ NotAsked = NotAsked + apply Loading _ = Loading + apply _ Loading = Loading + +instance bindStreamData :: Bind (StreamData e) where + bind NotAsked _ = NotAsked + bind Loading _ = Loading + bind (Failure err) _ = (Failure err) + bind (Success value) f = f value + bind (Refreshing value) f = f value + +instance applicativeStreamData :: Applicative (StreamData e) where + pure value = Success value + +instance monadStreamData :: Monad (StreamData e) + +instance monadThrowStreamData :: MonadThrow e (StreamData e) where + throwError = Failure + +instance monadErrorStreamData :: MonadError e (StreamData e) where + catchError (Failure e) f = f e + catchError (Success value) _ = Success value + catchError (Refreshing value) _ = Refreshing value + catchError NotAsked _ = NotAsked + catchError Loading _ = Loading + +instance foldableStreamData :: Foldable (StreamData e) where + foldMap f (Success a) = f a + foldMap f (Refreshing a) = f a + foldMap _ (Failure e) = mempty + foldMap _ NotAsked = mempty + foldMap _ Loading = mempty + foldr f = foldrDefault f + foldl f = foldlDefault f + +instance traversableStreamData :: Traversable (StreamData e) where + traverse f (Success a) = Success <$> f a + traverse f (Refreshing a) = Refreshing <$> f a + traverse f (Failure e) = pure (Failure e) + traverse _ NotAsked = pure NotAsked + traverse _ Loading = pure Loading + sequence = sequenceDefault + +instance bifoldableStreamData :: Bifoldable StreamData where + bifoldMap _ f (Success a) = f a + bifoldMap _ f (Refreshing a) = f a + bifoldMap f _ (Failure e) = f e + bifoldMap _ _ Loading = mempty + bifoldMap _ _ NotAsked = mempty + bifoldr f = bifoldrDefault f + bifoldl f = bifoldlDefault f + +instance bitraversableStreamData :: Bitraversable StreamData where + bitraverse _ f (Success a) = Success <$> f a + bitraverse _ f (Refreshing a) = Refreshing <$> f a + bitraverse f _ (Failure e) = Failure <$> f e + bitraverse _ _ NotAsked = pure NotAsked + bitraverse _ _ Loading = pure Loading + bisequence = bisequenceDefault + +------------------------------------------------------------ +-- | Convert an `Either` to `StreamData` +fromEither :: forall e a. Either e a -> StreamData e a +fromEither (Left err) = Failure err + +fromEither (Right value) = Success value + +-- | Modifies any `Success a` to be `Refreshing a`. +refreshing :: forall e a. StreamData e a -> StreamData e a +refreshing (Success a) = Refreshing a + +refreshing NotAsked = Loading + +refreshing other = other + +-- | Modifies any `Refreshing a` to be a `Success a`. +refreshed :: forall e a. StreamData e a -> StreamData e a +refreshed (Refreshing a) = Success a + +refreshed other = other + +------------------------------------------------------------ +-- Prisms & Lenses (oh my!) +_NotAsked :: forall a e. Prism' (StreamData e a) Unit +_NotAsked = prism (const NotAsked) unwrap + where + unwrap NotAsked = Right unit + + unwrap y = Left y + +_Loading :: forall a e. Prism' (StreamData e a) Unit +_Loading = prism (const Loading) unwrap + where + unwrap Loading = Right unit + + unwrap y = Left y + +_Failure :: forall a e. Prism' (StreamData e a) e +_Failure = prism Failure unwrap + where + unwrap (Failure x) = Right x + + unwrap y = Left y + +_Refreshing :: forall a e. Prism' (StreamData e a) a +_Refreshing = prism Refreshing unwrap + where + unwrap (Refreshing x) = Right x + + unwrap y = Left y + +_Success :: forall a e. Prism' (StreamData e a) a +_Success = prism Success unwrap + where + unwrap (Success x) = Right x + + unwrap y = Left y + +------------------------------------------------------------ +fromRemoteData :: forall e a. RemoteData e a -> StreamData e a +fromRemoteData (Remote.Success a) = Success a + +fromRemoteData (Remote.Failure e) = Failure e + +fromRemoteData Remote.Loading = Loading + +fromRemoteData Remote.NotAsked = NotAsked + +toRemoteData :: forall e a. StreamData e a -> RemoteData e a +toRemoteData (Success a) = Remote.Success a + +toRemoteData (Refreshing a) = Remote.Success a + +toRemoteData (Failure e) = Remote.Failure e + +toRemoteData Loading = Remote.Loading + +toRemoteData NotAsked = Remote.NotAsked + +isAvailable :: forall e a. StreamData e a -> Boolean +isAvailable (Success _) = true + +isAvailable (Refreshing _) = true + +isAvailable _ = false + +isExpected :: forall e a. StreamData e a -> Boolean +isExpected (Refreshing _) = true + +isExpected Loading = true + +isExpected _ = false diff --git a/plutus-scb-client/src/Types.purs b/plutus-scb-client/src/Types.purs index aa2240f0e40..a62e2b5c9c7 100644 --- a/plutus-scb-client/src/Types.purs +++ b/plutus-scb-client/src/Types.purs @@ -3,6 +3,7 @@ module Types where import Prelude import Chain.Types as Chain import Control.Monad.Gen as Gen +import Data.Bifunctor (lmap) import Data.Generic.Rep (class Generic) import Data.Generic.Rep.Show (genericShow) import Data.Json.JsonMap (JsonMap) @@ -23,6 +24,8 @@ import Ledger.Index (UtxoIndex) import Ledger.Tx (Tx) import Ledger.TxId (TxId) import Network.RemoteData (RemoteData) +import Network.StreamData (StreamData) +import Network.StreamData as Stream import Playground.Types (FunctionSchema) import Plutus.SCB.Events (ChainEvent) import Plutus.SCB.Events.Contract (ContractInstanceId, ContractInstanceState, ContractSCBRequest, PartiallyDecodedResponse, _ContractInstanceState, _UserEndpointRequest) @@ -41,9 +44,19 @@ data Query a data Output = SendWebSocketMessage (WS.Input StreamToServer) +data StreamError + = DecodingError MultipleErrors + | TransportError AjaxError + +type WebStreamData + = StreamData StreamError + type WebData = RemoteData AjaxError +fromWebData :: forall a. WebData a -> WebStreamData a +fromWebData = Stream.fromRemoteData <<< lmap TransportError + data HAction = Init | ChangeView View @@ -53,15 +66,21 @@ data HAction | ChangeContractEndpointCall ContractInstanceId Int FormEvent | InvokeContractEndpoint ContractInstanceId EndpointForm +type ContractStates + = Map ContractInstanceId (WebStreamData (ContractInstanceState ContractExe /\ Array EndpointForm)) + +type ContractSignatures + = Array (ContractSignatureResponse ContractExe) + newtype State = State { currentView :: View - , contractSignatures :: WebData (Array (ContractSignatureResponse ContractExe)) + , contractSignatures :: WebStreamData ContractSignatures , chainReport :: WebData (ChainReport ContractExe) , events :: WebData (Array (ChainEvent ContractExe)) , chainState :: Chain.State - , contractStates :: Map ContractInstanceId (WebData (ContractInstanceState ContractExe /\ Array EndpointForm)) - , webSocketMessage :: RemoteData MultipleErrors StreamToClient + , contractStates :: ContractStates + , webSocketMessage :: WebStreamData StreamToClient } type EndpointForm @@ -88,7 +107,7 @@ _events = _Newtype <<< prop (SProxy :: SProxy "events") _chainState :: Lens' State Chain.State _chainState = _Newtype <<< prop (SProxy :: SProxy "chainState") -_contractStates :: Lens' State (Map ContractInstanceId (WebData (ContractInstanceState ContractExe /\ Array EndpointForm))) +_contractStates :: Lens' State (Map ContractInstanceId (WebStreamData (ContractInstanceState ContractExe /\ Array EndpointForm))) _contractStates = _Newtype <<< prop (SProxy :: SProxy "contractStates") _annotatedBlockchain :: forall t. Lens' (ChainReport t) (Array (Array AnnotatedTx)) diff --git a/plutus-scb-client/src/View.purs b/plutus-scb-client/src/View.purs index f8a511b32ff..5cec8d1e3a7 100644 --- a/plutus-scb-client/src/View.purs +++ b/plutus-scb-client/src/View.purs @@ -4,23 +4,20 @@ import Bootstrap (col12_, col5_, col7_, container_, row_) import Chain.Types as Chain import Data.Lens (traversed, view) import Data.Lens.Extra (toArrayOf) -import Data.Map (Map) -import Data.Tuple (Tuple) -import Data.Tuple.Nested (type (/\), tuple3, uncurry3) import Effect.Aff.Class (class MonadAff) import Halogen.HTML (ClassName(..), ComponentHTML, HTML, div, div_, h1, text) import Halogen.HTML.Properties (class_) import NavTabs (mainTabBar, viewContainer) +import Network.StreamData as Stream import Plutus.SCB.Events (ChainEvent) -import Plutus.SCB.Events.Contract (ContractInstanceId, ContractInstanceState) import Plutus.SCB.Types (ContractExe) -import Plutus.SCB.Webserver.Types (ChainReport, ContractReport, ContractSignatureResponse(..)) -import Prelude (($), (<$>), (<*>), (<<<)) -import Types (EndpointForm, HAction(..), State(..), View(..), WebData, _crAvailableContracts, _csrDefinition, _utxoIndex) +import Plutus.SCB.Webserver.Types (ChainReport) +import Prelude (($), (<$>), (<<<)) +import Types (ContractSignatures, ContractStates, HAction(..), State(..), View(..), WebStreamData, _csrDefinition, _utxoIndex) import View.Blockchain (annotatedBlockchainPane) import View.Contracts (contractStatusesPane, installedContractsPane) import View.Events (eventsPane, utxoIndexPane) -import View.Utils (webDataPane) +import View.Utils (streamErrorPane, webDataPane2, webStreamDataPane) render :: forall m slots. @@ -33,11 +30,14 @@ render (State { currentView, chainState, contractSignatures, chainReport, events [ mainHeader , mainTabBar ChangeView tabs currentView , div_ - $ webDataPane - ( uncurry3 - (mainPane currentView contractStates chainState) - ) - (tuple3 <$> contractSignatures <*> chainReport <*> events) + $ case webSocketMessage of + Stream.Failure error -> [ streamErrorPane error ] + _ -> [] + , div_ + $ webDataPane2 + (mainPane currentView contractStates chainState contractSignatures) + chainReport + events ] ] @@ -68,46 +68,45 @@ tabs = mainPane :: forall p t. View -> - Map ContractInstanceId (WebData (ContractInstanceState t /\ Array EndpointForm)) -> + ContractStates -> Chain.State -> - Array (ContractSignatureResponse ContractExe) -> + WebStreamData ContractSignatures -> ChainReport t -> Array (ChainEvent ContractExe) -> HTML p HAction mainPane currentView contractStates chainState contractSignatures chainReport events = row_ - [ activeContractPane currentView contractStates contractSignatures + [ activeContractPane currentView contractSignatures contractStates , blockchainPane currentView chainState chainReport , eventLogPane currentView events chainReport ] activeContractPane :: - forall p t. + forall p. View -> - Map ContractInstanceId - ( WebData - ( Tuple (ContractInstanceState t) - ( Array - EndpointForm - ) - ) - ) -> - Array (ContractSignatureResponse ContractExe) -> HTML p HAction -activeContractPane currentView contractStates contractSignatures = - viewContainer currentView ActiveContracts - [ row_ - [ col12_ [ contractStatusesPane contractStates ] - , col12_ - [ installedContractsPane - ( toArrayOf - ( traversed - <<< _csrDefinition - ) - contractSignatures - ) - ] - ] - ] + WebStreamData ContractSignatures -> + ContractStates -> + HTML p HAction +activeContractPane currentView contractSignatures contractStates = + let + buttonsDisabled = Stream.isExpected contractSignatures + in + viewContainer currentView ActiveContracts + [ row_ + [ col12_ [ contractStatusesPane contractStates ] + , col12_ + ( webStreamDataPane + ( installedContractsPane buttonsDisabled + <<< ( toArrayOf + ( traversed + <<< _csrDefinition + ) + ) + ) + contractSignatures + ) + ] + ] blockchainPane :: forall p t. diff --git a/plutus-scb-client/src/View/Contracts.purs b/plutus-scb-client/src/View/Contracts.purs index ba758b47a57..4f3ca898b88 100644 --- a/plutus-scb-client/src/View/Contracts.purs +++ b/plutus-scb-client/src/View/Contracts.purs @@ -1,36 +1,38 @@ module View.Contracts where -import Prelude +import Prelude hiding (div) import Bootstrap (btn, btnBlock, btnPrimary, btnSmall, cardBody_, cardFooter_, cardHeader_, card_, col10_, col2_, col4_, nbsp, row_, tableBordered) import Bootstrap as Bootstrap import Data.Array (mapWithIndex, null) +import Data.Array as Array import Data.Foldable.Extra (interleave) -import Data.Lens (_1, filtered, toArrayOf, traversed, view) -import Data.Map (Map) +import Data.Lens (_1, view) import Data.Map as Map import Data.Maybe (Maybe(..)) import Data.Tuple.Nested (type (/\), (/\)) -import Halogen.HTML (HTML, br_, button, div_, h2_, h3_, table, tbody_, td_, text, th, th_, thead_, tr_) +import Halogen.HTML (ClassName(..), HTML, br_, button, div, div_, h2_, h3_, table, tbody_, td_, text, th, thead_, tr_) import Halogen.HTML.Events (onClick) -import Halogen.HTML.Properties (classes, colSpan) +import Halogen.HTML.Properties (class_, classes, colSpan, disabled) +import Icons (Icon(..), icon) import Language.Plutus.Contract.Resumable (IterationID(..), Request(..), RequestID(..)) -import Network.RemoteData (_Success) +import Network.StreamData as Stream import Playground.Lenses (_endpointDescription, _getEndpointDescription, _schema) import Playground.Schema (actionArgumentForm) import Playground.Types (_FunctionSchema) import Plutus.SCB.Events.Contract (ContractInstanceId, ContractInstanceState) import Plutus.SCB.Types (ContractExe) import Schema.Types (FormEvent) -import Types (EndpointForm, HAction(..), WebData, _contractInstanceIdString, _contractPath, _csContract, _csCurrentState, _hooks) +import Types (ContractStates, EndpointForm, HAction(..), WebStreamData, _contractInstanceIdString, _contractPath, _csContract, _csContractDefinition, _csCurrentState, _hooks) import Validation (_argument) import View.Pretty (pretty) -import View.Utils (webDataPane) +import View.Utils (webStreamDataPane) installedContractsPane :: forall p. + Boolean -> Array ContractExe -> HTML p HAction -installedContractsPane installedContracts = +installedContractsPane buttonsDisabled installedContracts = card_ [ cardHeader_ [ h2_ [ text "Installed Contracts" ] @@ -39,31 +41,33 @@ installedContractsPane installedContracts = [ if null installedContracts then text "You do not have any contracts installed." else - div_ (interleave br_ (installedContractPane <$> installedContracts)) + div_ (interleave br_ (installedContractPane buttonsDisabled <$> installedContracts)) ] ] installedContractPane :: forall p. + Boolean -> ContractExe -> HTML p HAction -installedContractPane installedContract = +installedContractPane buttonsDisabled installedContract = row_ [ col2_ [ button [ classes [ btn, btnSmall, btnPrimary, btnBlock ] , onClick (const $ Just $ ActivateContract installedContract) + , disabled buttonsDisabled ] - [ text "Activate" ] + [ if buttonsDisabled then icon Spinner else text "Activate" ] ] , col10_ [ text $ view _contractPath installedContract ] ] contractStatusesPane :: - forall p t. - Map ContractInstanceId (WebData (ContractInstanceState t /\ Array EndpointForm)) -> + forall p. + ContractStates -> HTML p HAction -contractStatusesPane contractSignatures = +contractStatusesPane contractStates = card_ [ cardHeader_ [ h2_ [ text "Active Contracts" ] @@ -72,58 +76,65 @@ contractStatusesPane contractSignatures = [ if null contractsWithRequests then text "You do not have any active contracts." else - div_ (contractStatusPane contractSignatures <$> contractsWithRequests) + div_ (contractStatusPane <$> contractsWithRequests) ] ] where - contractsWithRequests :: Array (ContractInstanceState t) - contractsWithRequests = toArrayOf (traversed <<< _Success <<< _1 <<< filtered hasActiveRequests) contractSignatures + contractsWithRequests :: Array (WebStreamData (ContractInstanceState ContractExe /\ Array EndpointForm)) + contractsWithRequests = Array.filter hasActiveRequests $ Array.fromFoldable $ Map.values contractStates + + hasActiveRequests :: WebStreamData (ContractInstanceState ContractExe /\ Array EndpointForm) -> Boolean + hasActiveRequests contractInstance = not $ null $ view (Stream._Success <<< _1 <<< _csCurrentState <<< _hooks) contractInstance contractStatusPane :: - forall p t. - Map ContractInstanceId (WebData (ContractInstanceState t /\ Array EndpointForm)) -> - ContractInstanceState t -> HTML p HAction -contractStatusPane contractSignatures contractInstance = - div_ - [ contractRequestView contractInstance - , div_ - ( case Map.lookup contractInstanceId contractSignatures of - Just remoteData -> - webDataPane - ( \(_ /\ endpointForms) -> - row_ - ( mapWithIndex - (\index endpointForm -> actionCard contractInstanceId (ChangeContractEndpointCall contractInstanceId index) endpointForm) - endpointForms - ) - ) - remoteData - Nothing -> [] + forall p. + WebStreamData (ContractInstanceState ContractExe /\ Array EndpointForm) -> + HTML p HAction +contractStatusPane contractState = + div [ class_ $ ClassName "contract-status" ] + $ webStreamDataPane + ( \(contractInstance /\ endpointForms) -> + let + contractInstanceId :: ContractInstanceId + contractInstanceId = view _csContract contractInstance + in + div_ + [ contractRequestView contractInstance + , div_ + [ row_ + ( mapWithIndex + (\index endpointForm -> actionCard contractInstanceId (ChangeContractEndpointCall contractInstanceId index) endpointForm) + endpointForms + ) + ] + ] ) - ] - where - contractInstanceId :: ContractInstanceId - contractInstanceId = view _csContract contractInstance + contractState -contractRequestView :: forall t p i. ContractInstanceState t -> HTML p i +contractRequestView :: forall p i. ContractInstanceState ContractExe -> HTML p i contractRequestView contractInstance = table [ classes [ Bootstrap.table, tableBordered ] ] [ thead_ [ tr_ [ th [ colSpan 3 ] - [ h3_ [ text contractTitle ] ] + [ h3_ + [ pretty $ view (_csContractDefinition) contractInstance + , nbsp + , text "-" + , nbsp + , text $ view (_csContract <<< _contractInstanceIdString) contractInstance + ] + ] ] , tr_ - [ th_ [ text "Iteration" ] - , th_ [ text "Request", nbsp, text "ID" ] - , th_ [ text "Request" ] + [ th [ class_ $ ClassName "iteration-id" ] [ text "Iteration" ] + , th [ class_ $ ClassName "request-id" ] [ text "Request", nbsp, text "ID" ] + , th [ class_ $ ClassName "request" ] [ text "Request" ] ] ] , tbody_ (requestRow <$> requests) ] where - contractTitle = view (_csContract <<< _contractInstanceIdString) contractInstance - requests = view (_csCurrentState <<< _hooks) contractInstance requestRow (Request { itID: IterationID itID, rqID: RequestID rqID, rqRequest }) = @@ -133,9 +144,6 @@ contractRequestView contractInstance = , td_ [ pretty rqRequest ] ] -hasActiveRequests :: forall t. ContractInstanceState t -> Boolean -hasActiveRequests contractInstance = not $ null $ view (_csCurrentState <<< _hooks) contractInstance - actionCard :: forall p. ContractInstanceId -> (FormEvent -> HAction) -> EndpointForm -> HTML p HAction actionCard contractInstanceId wrapper endpointForm = col4_ diff --git a/plutus-scb-client/src/View/Utils.purs b/plutus-scb-client/src/View/Utils.purs index c690b9eedc6..bda9df0b660 100644 --- a/plutus-scb-client/src/View/Utils.purs +++ b/plutus-scb-client/src/View/Utils.purs @@ -1,16 +1,79 @@ -module View.Utils (webDataPane) where +module View.Utils + ( webDataPane + , webDataPane2 + , webStreamDataPane + , streamErrorPane + ) where -import Halogen.HTML (HTML) +import Prelude hiding (div) import AjaxUtils (ajaxErrorPane) +import Bootstrap (alertDanger_) +import Data.Array as Array +import Data.Tuple.Nested (tuple2, uncurry2) +import Foreign (renderForeignError) +import Halogen.HTML (ClassName(..), HTML, br_, div, div_, text) +import Halogen.HTML.Properties (class_) import Icons (Icon(..), icon) -import Network.RemoteData (RemoteData(..)) -import Types (WebData) +import Network.RemoteData as Remote +import Network.StreamData as Stream +import Types (StreamError(..), WebData, WebStreamData) +-- | Make it easy to display successful `WebData` and render the other states in a consistent way. webDataPane :: forall a p i. (a -> HTML p i) -> WebData a -> Array (HTML p i) -webDataPane successView (Success report) = [ successView report ] +webDataPane successView (Remote.Success value) = [ successView value ] -webDataPane _ (Failure error) = [ ajaxErrorPane error ] +webDataPane _ (Remote.Failure error) = [ ajaxErrorPane error ] -webDataPane _ (Loading) = [ icon Spinner ] +webDataPane _ (Remote.Loading) = + [ div + [ class_ $ ClassName "web-data-loading" ] + [ icon Spinner ] + ] -webDataPane _ (NotAsked) = [ icon Spinner ] +webDataPane successView (Remote.NotAsked) = webDataPane successView Remote.Loading + +-- | `webDataPane` with two `WebData` arguments. +webDataPane2 :: forall a b p i. (a -> b -> HTML p i) -> WebData a -> WebData b -> Array (HTML p i) +webDataPane2 successView a b = + webDataPane + (uncurry2 successView) + (tuple2 <$> a <*> b) + +------------------------------------------------------------ +streamDataRefreshing :: ClassName +streamDataRefreshing = ClassName "stream-data-refreshing" + +streamDataRefreshingContent :: ClassName +streamDataRefreshingContent = streamDataRefreshing <> ClassName "-content" + +-- | Make it easy to display successful `WebStreamData` and render the other states in a consistent way. +webStreamDataPane :: forall a p i. (a -> HTML p i) -> WebStreamData a -> Array (HTML p i) +webStreamDataPane successView (Stream.Success value) = [ successView value ] + +webStreamDataPane successView (Stream.Refreshing value) = + [ div + [ class_ streamDataRefreshing ] + [ icon Spinner + , div [ class_ streamDataRefreshingContent ] + [ successView value ] + ] + ] + +webStreamDataPane _ (Stream.Failure error) = [ streamErrorPane error ] + +webStreamDataPane _ (Stream.Loading) = [ icon Spinner ] + +webStreamDataPane _ (Stream.NotAsked) = [ icon Spinner ] + +streamErrorPane :: forall p i. StreamError -> HTML p i +streamErrorPane (TransportError error) = ajaxErrorPane error + +streamErrorPane (DecodingError errors) = + div + [ class_ $ ClassName "ajax-error" ] + [ alertDanger_ + [ div_ (text <<< renderForeignError <$> Array.fromFoldable errors) + , br_ + , text "Please try again or contact support for assistance." + ] + ] diff --git a/plutus-scb-client/static/main.scss b/plutus-scb-client/static/main.scss index 5b2d58406a2..57394c0d1f6 100644 --- a/plutus-scb-client/static/main.scss +++ b/plutus-scb-client/static/main.scss @@ -1,2 +1,37 @@ @import '../../web-common/static/main.scss'; @import '../../web-common/static/chain.scss'; + +.web-data-loading, +.stream-data-refreshing { + .web-data-loading-content , + .stream-data-refreshing-content { + opacity: 0.5; + } + + & > .fa-spinner { + $spinner-height: 50px; + position: absolute; + top: 50%; + left: 50%; + height: $spinner-height; + width: $spinner-height; + margin-left: - ($spinner-height / 2); + margin-top: - ($spinner-height / 2); + font-size: $spinner-height; + text-align: center; + display: flex; + align-items: center; + justify-content: center; + + z-index: 10; + } +} + +.contract-status { + table { + .iteration-id , + .request-id { + width: 3rem; + } + } +} diff --git a/plutus-scb/src/Plutus/SCB/Webserver/Handler.hs b/plutus-scb/src/Plutus/SCB/Webserver/Handler.hs index 491aa3870cb..bf9ed35847f 100644 --- a/plutus-scb/src/Plutus/SCB/Webserver/Handler.hs +++ b/plutus-scb/src/Plutus/SCB/Webserver/Handler.hs @@ -14,6 +14,7 @@ module Plutus.SCB.Webserver.Handler , getFullReport , getChainReport , getContractReport + , getEvents , contractSchema ) where @@ -92,6 +93,11 @@ getChainReport = do , walletMap } +getEvents :: + forall t effs. (Member (EventLogEffect (ChainEvent t)) effs) + => Eff effs [ChainEvent t] +getEvents = fmap streamEventEvent <$> runGlobalQuery Query.pureProjection + getFullReport :: forall t effs. ( Member (EventLogEffect (ChainEvent t)) effs diff --git a/plutus-scb/src/Plutus/SCB/Webserver/WebSocket.hs b/plutus-scb/src/Plutus/SCB/Webserver/WebSocket.hs index c436f877dab..e322e594c11 100644 --- a/plutus-scb/src/Plutus/SCB/Webserver/WebSocket.hs +++ b/plutus-scb/src/Plutus/SCB/Webserver/WebSocket.hs @@ -20,6 +20,7 @@ import Control.Monad.Freer.Reader (Reader, ask) import Control.Monad.Freer.WebSocket (WebSocketEffect, acceptConnection, sendJSON) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (LogLevel (LevelDebug)) +import Data.Aeson (ToJSON) import Data.Time.Units (Second, TimeUnit) import Network.WebSockets.Connection (Connection, PendingConnection, withPingThread) import Plutus.SCB.App (runApp) @@ -27,17 +28,11 @@ import Plutus.SCB.Effects.Contract (ContractEffect) import Plutus.SCB.Effects.EventLog (EventLogEffect) import Plutus.SCB.Events (ChainEvent) import Plutus.SCB.Types (Config, ContractExe, SCBError) -import Plutus.SCB.Webserver.Handler (getChainReport, getContractReport) +import Plutus.SCB.Webserver.Handler (getChainReport, getContractReport, getEvents) import Plutus.SCB.Webserver.Types (StreamToClient (NewChainReport, NewContractReport), WebSocketLogMsg (ClosedConnection, CreatedConnection)) import Wallet.Effects (ChainIndexEffect) -timeBetweenChainReports :: Second -timeBetweenChainReports = 10 - -timeBetweenEvents :: Second -timeBetweenEvents = 3 - ------------------------------------------------------------ -- Message processors. ------------------------------------------------------------ @@ -48,11 +43,7 @@ chainReportThread :: ) => Connection -> Eff effs () -chainReportThread connection = - pollAndNotifyOnChange timeBetweenChainReports getChainReport notify - where - notify newReport = - sendJSON connection $ NewChainReport newReport +chainReportThread = watchAndNotify (5 :: Second) getChainReport NewChainReport contractStateThread :: ( Member WebSocketEffect effs @@ -62,11 +53,33 @@ contractStateThread :: ) => Connection -> Eff effs () -contractStateThread connection = - pollAndNotifyOnChange timeBetweenEvents getContractReport notify - where - notify newReport = - sendJSON connection $ NewContractReport newReport +contractStateThread = + watchAndNotify (3 :: Second) getContractReport NewContractReport + +eventsThread :: + ( Member WebSocketEffect effs + , Member (EventLogEffect (ChainEvent ContractExe)) effs + , Member DelayEffect effs + ) + => Connection + -> Eff effs () +eventsThread = + watchAndNotify (15 :: Second) getEvents NewChainEvents + +watchAndNotify :: + ( TimeUnit t + , Member DelayEffect effs + , Member WebSocketEffect effs + , Eq a + , ToJSON b + ) + => t + -> Eff effs a + -> (a -> b) + -> Connection + -> Eff effs () +watchAndNotify time query wrapper connection = + watchForChanges time query (sendJSON connection . wrapper) -- TODO Polling is icky. But we can't use Eventful's hook system -- because that relies all events coming in from the same thread. We @@ -75,13 +88,13 @@ contractStateThread connection = -- -- Can we use the DB commit hook instead? -- https://www.sqlite.org/c3ref/commit_hook.html -pollAndNotifyOnChange :: +watchForChanges :: (TimeUnit t, Eq a, Member DelayEffect effs) => t -> Eff effs a -> (a -> Eff effs ()) -> Eff effs () -pollAndNotifyOnChange time query notify = go Nothing +watchForChanges time query notify = go Nothing where go oldValue = do newValue <- query @@ -99,6 +112,7 @@ threadApp config connection = do asyncApp [ chainReportThread connection , contractStateThread connection + , eventsThread connection ] void $ waitAnyCancel tasks where