SCB: Adding the scaffolding for better frontend tests.

Similar to the other two frontends, we introduce `MonadApp` for all
the side-effecting calls, so we can replace them with mock
implementations in a test environment.

plutus-scb-client/src/MainFrame.purs

@@ -1,17 +1,17 @@
 module MainFrame
   ( initialMainFrame
+  , handleQuery
   , handleAction
   , initialState
   ) where
 
 import Prelude hiding (div)
-import Animation (animate)
+import Animation (class MonadAnimate, animate)
 import Chain.Eval (handleAction) as Chain
 import Chain.Types (Action(..), AnnotatedBlockchain(..), _chainFocusAppearing)
 import Chain.Types (initialState) as Chain
 import Clipboard (class MonadClipboard)
-import Control.Monad.Except.Trans (ExceptT, runExceptT)
-import Control.Monad.Reader (class MonadAsk, runReaderT)
+import Control.Monad.Reader (runReaderT)
 import Control.Monad.State (class MonadState)
 import Control.Monad.State.Extra (zoomStateT)
 import Data.Array (filter)
@@ -28,31 +28,29 @@ import Data.Set as Set
 import Data.Traversable (for_, sequence, traverse_)
 import Data.Tuple (Tuple(..))
 import Effect.Aff.Class (class MonadAff)
-import Effect.Class (class MonadEffect, liftEffect)
-import Effect.Console (log)
 import Foreign.Generic (encodeJSON)
-import Halogen (Component, HalogenM, hoist, raise)
+import Halogen (Component, hoist)
 import Halogen as H
 import Halogen.HTML (HTML)
 import Language.Plutus.Contract.Effects.ExposeEndpoint (EndpointDescription)
 import Ledger.Ada (Ada(..))
 import Ledger.Extra (adaToValue)
 import Ledger.Value (Value)
+import MonadApp (class MonadApp, activateContract, getFullReport, invokeEndpoint, log, runHalogenApp, sendWebSocketMessage)
 import Network.RemoteData (RemoteData(..), _Success)
 import Network.RemoteData as RemoteData
-import Playground.Lenses (_endpointDescription, _getEndpointDescription, _schema)
+import Playground.Lenses (_endpointDescription, _schema)
 import Playground.Types (FunctionSchema(..), _FunctionSchema)
 import Plutus.SCB.Events.Contract (ContractInstanceState(..))
 import Plutus.SCB.Types (ContractExe)
-import Plutus.SCB.Webserver (SPParams_(..), getApiFullreport, postApiContractActivate, postApiContractByContractinstanceidEndpointByEndpointname)
+import Plutus.SCB.Webserver (SPParams_(..))
 import Plutus.SCB.Webserver.Types (ContractReport, ContractSignatureResponse(..), StreamToClient(..), StreamToServer(..))
 import Prim.TypeError (class Warn, Text)
 import Schema (FormSchema)
 import Schema.Types (formArgumentToJson, toArgument)
 import Schema.Types as Schema
-import Servant.PureScript.Ajax (AjaxError)
 import Servant.PureScript.Settings (SPSettings_, defaultSettings)
-import Types (EndpointForm, HAction(..), Output(..), Query(..), State(..), View(..), WebData, _annotatedBlockchain, _chainReport, _chainState, _contractActiveEndpoints, _contractInstanceIdString, _contractReport, _contractSignatures, _contractStates, _crAvailableContracts, _csContract, _csCurrentState, _currentView, _events, _webSocketMessage)
+import Types (EndpointForm, HAction(..), Output, Query(..), State(..), View(..), WebData, _annotatedBlockchain, _chainReport, _chainState, _contractActiveEndpoints, _contractReport, _contractSignatures, _contractStates, _crAvailableContracts, _csContract, _csCurrentState, _currentView, _events, _webSocketMessage)
 import Validation (_argument)
 import View as View
 import WebSocket.Support as WS
@@ -88,8 +86,8 @@ initialMainFrame =
         , render: View.render
         , eval:
           H.mkEval
-            { handleAction
-            , handleQuery
+            { handleAction: runHalogenApp <<< handleAction
+            , handleQuery: runHalogenApp <<< handleQuery
             , initialize: Just Init
             , receive: const Nothing
             , finalize: Nothing
@@ -100,10 +98,8 @@ handleQuery ::
   forall m a.
   Warn (Text "Handle WebSocket errors.") =>
   Warn (Text "Handle WebSocket disconnections.") =>
-  MonadAff m =>
-  MonadAsk (SPSettings_ SPParams_) m =>
   MonadState State m =>
-  MonadEffect m =>
+  MonadApp m =>
   Query a -> m (Maybe a)
 handleQuery (ReceiveWebSocketMessage (WS.ReceiveMessage msg) next) = do
   case msg of
@@ -120,27 +116,27 @@ handleQuery (ReceiveWebSocketMessage (WS.ReceiveMessage msg) next) = do
   pure $ Just next
 
 handleQuery (ReceiveWebSocketMessage WS.WebSocketClosed next) = do
-  liftEffect $ log "Closed"
+  log "Closed"
   pure $ Just next
 
 handleAction ::
-  forall action slots m.
-  MonadAff m =>
+  forall m.
+  MonadApp m =>
+  MonadAnimate m State =>
   MonadClipboard m =>
-  MonadAsk (SPSettings_ SPParams_) m =>
-  MonadEffect m =>
-  HAction -> HalogenM State action slots Output m Unit
+  MonadState State m =>
+  HAction -> m Unit
 handleAction Init = handleAction LoadFullReport
 
 handleAction (ChangeView view) = do
   sendWebSocketMessage $ Ping $ show view
   assign _currentView view
 
-handleAction (ActivateContract contract) = void $ runAjax $ postApiContractActivate contract
+handleAction (ActivateContract contract) = activateContract contract
 
 handleAction LoadFullReport = do
   assignFullReportData Loading
-  fullReportResult <- runAjax getApiFullreport
+  fullReportResult <- getFullReport
   assignFullReportData fullReportResult
   for_ fullReportResult
     ( \report ->
@@ -159,7 +155,7 @@ handleAction (ChainAction subaction) = do
   let
     wrapper ::
       Warn (Text "The question, 'Should we animate this?' feels like it belongs in the Chain module. Not here.") =>
-      HalogenM State action slots Output m Unit -> HalogenM State action slots Output m Unit
+      m Unit -> m Unit
     wrapper = case subaction of
       (FocusTx _) -> animate (_chainState <<< _chainFocusAppearing)
       _ -> identity
@@ -188,18 +184,10 @@ handleAction (InvokeContractEndpoint contractInstanceId endpointForm) = do
   for_ encodedForm
     $ \argument -> do
         assign (_contractSignatures <<< at contractInstanceId) (Just Loading)
-        runAjax
-          $ let
-              instanceId = view _contractInstanceIdString contractInstanceId
-
-              endpoint = view _getEndpointDescription endpointDescription
-            in
-              postApiContractByContractinstanceidEndpointByEndpointname argument instanceId endpoint
+        invokeEndpoint argument contractInstanceId endpointDescription
 
 updateFormsForContractInstance ::
   forall m.
-  MonadAsk (SPSettings_ SPParams_) m =>
-  MonadAff m =>
   MonadState State m =>
   ContractInstanceState ContractExe -> m Unit
 updateFormsForContractInstance newContractInstance = do
@@ -273,9 +261,3 @@ getMatchingSignature (ContractInstanceState { csContractDefinition }) =
     isMatch
   where
   isMatch (ContractSignatureResponse { csrDefinition }) = csrDefinition == csContractDefinition
-
-runAjax :: forall m a. Functor m => ExceptT AjaxError m a -> m (WebData a)
-runAjax action = RemoteData.fromEither <$> runExceptT action
-
-sendWebSocketMessage :: forall state action slots m. StreamToServer ContractExe -> HalogenM state action slots Output m Unit
-sendWebSocketMessage msg = raise $ SendWebSocketMessage $ WS.SendMessage msg

plutus-scb-client/src/MonadApp.purs

@@ -0,0 +1,85 @@
+module MonadApp where
+
+import Prelude
+import Animation (class MonadAnimate, animate)
+import Clipboard (class MonadClipboard, copy)
+import Control.Monad.Except (ExceptT, runExceptT)
+import Control.Monad.Reader.Class (class MonadAsk)
+import Control.Monad.State.Class (class MonadState)
+import Control.Monad.Trans.Class (class MonadTrans)
+import Data.Lens (view)
+import Data.Newtype (class Newtype, unwrap)
+import Data.RawJson (RawJson)
+import Effect.Aff.Class (class MonadAff)
+import Effect.Class (class MonadEffect)
+import Effect.Console as Console
+import Halogen (HalogenM, liftEffect, raise)
+import Language.Plutus.Contract.Effects.ExposeEndpoint (EndpointDescription)
+import Network.RemoteData as RemoteData
+import Playground.Lenses (_getEndpointDescription)
+import Plutus.SCB.Events.Contract (ContractInstanceId, ContractInstanceState)
+import Plutus.SCB.Types (ContractExe)
+import Plutus.SCB.Webserver (SPParams_, getApiFullreport, postApiContractActivate, postApiContractByContractinstanceidEndpointByEndpointname)
+import Plutus.SCB.Webserver.Types (FullReport, StreamToServer)
+import Servant.PureScript.Ajax (AjaxError)
+import Servant.PureScript.Settings (SPSettings_)
+import Types (HAction, Output(..), State, WebData, _contractInstanceIdString)
+import WebSocket.Support as WS
+
+class
+  Monad m <= MonadApp m where
+  getFullReport :: m (WebData (FullReport ContractExe))
+  invokeEndpoint :: RawJson -> ContractInstanceId -> EndpointDescription -> m (WebData (ContractInstanceState ContractExe))
+  activateContract :: ContractExe -> m Unit
+  sendWebSocketMessage :: StreamToServer ContractExe -> m Unit
+  log :: String -> m Unit
+
+newtype HalogenApp m a
+  = HalogenApp (HalogenM State HAction () Output m a)
+
+derive instance newtypeHalogenApp :: Newtype (HalogenApp m a) _
+
+derive newtype instance functorHalogenApp :: Functor (HalogenApp m)
+
+derive newtype instance applicativeHalogenApp :: Applicative (HalogenApp m)
+
+derive newtype instance applyHalogenApp :: Apply (HalogenApp m)
+
+derive newtype instance bindHalogenApp :: Bind (HalogenApp m)
+
+derive newtype instance monadHalogenApp :: Monad (HalogenApp m)
+
+derive newtype instance monadTransHalogenApp :: MonadTrans HalogenApp
+
+derive newtype instance monadStateHalogenApp :: MonadState State (HalogenApp m)
+
+derive newtype instance monadAskHalogenApp :: MonadAsk env m => MonadAsk env (HalogenApp m)
+
+derive newtype instance monadEffectHalogenApp :: MonadEffect m => MonadEffect (HalogenApp m)
+
+derive newtype instance monadAffHalogenApp :: MonadAff m => MonadAff (HalogenApp m)
+
+instance monadAnimateHalogenApp :: MonadAff m => MonadAnimate (HalogenApp m) State where
+  animate toggle action = HalogenApp $ animate toggle (unwrap action)
+
+instance monadClipboardHalogenApp :: MonadEffect m => MonadClipboard (HalogenApp m) where
+  copy = liftEffect <<< copy
+
+------------------------------------------------------------
+runHalogenApp :: forall m a. HalogenApp m a -> HalogenM State HAction () Output m a
+runHalogenApp = unwrap
+
+instance monadAppHalogenApp :: (MonadAff m, MonadAsk (SPSettings_ SPParams_) m) => MonadApp (HalogenApp m) where
+  getFullReport = runAjax getApiFullreport
+  invokeEndpoint payload contractInstanceId endpointDescription =
+    runAjax
+      $ postApiContractByContractinstanceidEndpointByEndpointname
+          payload
+          (view _contractInstanceIdString contractInstanceId)
+          (view _getEndpointDescription endpointDescription)
+  activateContract contract = void $ runAjax $ postApiContractActivate contract
+  sendWebSocketMessage msg = HalogenApp $ raise $ SendWebSocketMessage $ WS.SendMessage msg
+  log str = liftEffect $ Console.log str
+
+runAjax :: forall m a. Functor m => ExceptT AjaxError m a -> m (WebData a)
+runAjax action = RemoteData.fromEither <$> runExceptT action

plutus-scb-client/test/MainFrameTests.purs

@@ -3,7 +3,99 @@ module MainFrameTests
   ) where
 
 import Prelude
-import Test.Unit (TestSuite, suite)
+import Types (HAction(..), Query(..), State, _currentView)
+import Animation (class MonadAnimate)
+import Clipboard (class MonadClipboard)
+import Control.Monad.Except.Trans (class MonadThrow)
+import Control.Monad.RWS (RWSResult(..), RWST(..), runRWST)
+import Control.Monad.Reader.Class (class MonadAsk)
+import Control.Monad.State.Class (class MonadState)
+import Control.Monad.Trans.Class (class MonadTrans)
+import Data.Either (Either(..))
+import Data.Lens (_1, appendModifying, view)
+import Data.Lens.Record (prop)
+import Data.Newtype (class Newtype, unwrap, wrap)
+import Data.Symbol (SProxy(..))
+import Data.Traversable (traverse_)
+import Data.Tuple (Tuple(..))
+import Effect.Exception (Error)
+import MainFrame (handleQuery, handleAction)
+import MainFrame as MainFrame
+import MonadApp (class MonadApp)
+import Network.RemoteData (RemoteData(..))
+import Plutus.SCB.Webserver (SPParams_(..))
+import Servant.PureScript.Settings (SPSettings_, defaultSettings)
+import Test.QuickCheck ((<?>))
+import Test.Unit (TestSuite, failure, suite, test)
+import Test.Unit.Assert (equal)
+import Test.Unit.QuickCheck (quickCheck)
+import WebSocket.Support as WS
+
+type World
+  = { console :: Array String }
+
+execMockApp :: forall m a. MonadThrow Error m => World -> Array (Either (Query a) HAction) -> m (Tuple World State)
+execMockApp world queries = do
+  let
+    initialState = MainFrame.initialState
+
+    handle (Left query) = void $ handleQuery query
+
+    handle (Right action) = handleAction action
+  RWSResult state result writer <-
+    runRWST
+      (unwrap (traverse_ handle queries :: MockApp m Unit))
+      (defaultSettings (SPParams_ { baseURL: "/" }))
+      (Tuple world initialState)
+  pure state
+
+-- | A dummy implementation of `MonadApp`, for testing the main handleAction loop.
+newtype MockApp m a
+  = MockApp (RWST (SPSettings_ SPParams_) Unit (Tuple World State) m a)
+
+derive instance newtypeMockApp :: Newtype (MockApp m a) _
+
+derive newtype instance functorMockApp :: Functor m => Functor (MockApp m)
+
+derive newtype instance applicativeMockApp :: Monad m => Applicative (MockApp m)
+
+derive newtype instance applyMockApp :: Bind m => Apply (MockApp m)
+
+derive newtype instance bindMockApp :: Bind m => Bind (MockApp m)
+
+derive newtype instance monadMockApp :: Monad m => Monad (MockApp m)
+
+derive newtype instance monadTransMockApp :: MonadTrans MockApp
+
+derive newtype instance monadAskMockApp :: Monad m => MonadAsk (SPSettings_ SPParams_) (MockApp m)
+
+instance monadStateMockApp :: Monad m => MonadState State (MockApp m) where
+  state f =
+    MockApp
+      $ RWST \r (Tuple world appState) -> case f appState of
+          (Tuple a appState') -> pure $ RWSResult (Tuple world appState') a unit
+
+instance monadAppMockApp :: Monad m => MonadApp (MockApp m) where
+  activateContract _ = pure unit
+  invokeEndpoint _ _ _ = pure Loading
+  getFullReport = pure Loading
+  sendWebSocketMessage _ = pure unit
+  log msg =
+    wrap
+      $ appendModifying
+          (_1 <<< prop (SProxy :: SProxy "console"))
+          [ msg ]
+
+-- | The mock app makes no attempt to animate anything, and just calls the embedded `action`.
+instance monadAnimateMockApp :: MonadAnimate (MockApp m) State where
+  animate toggle action = action
+
+instance monadClipboardMockApp :: Monad m => MonadClipboard (MockApp m) where
+  copy _ = pure unit
+
+------------------------------------------------------------
+mockWorld :: World
+mockWorld = { console: [] }
 
 all :: TestSuite
 all =
@@ -13,4 +105,10 @@ all =
 evalTests :: TestSuite
 evalTests =
   suite "handleAction" do
-    pure unit
+    test "ChangeView" do
+      quickCheck \aView -> do
+        let
+          result = execMockApp mockWorld [ Right $ ChangeView aView ]
+        case result of
+          Right (Tuple _ finalState) -> (aView == view _currentView finalState) <?> "Unexpected final view."
+          Left err -> false <?> show err