Merge pull request #45 from input-output-hk/PLT-7427

PLT-7427 - Add button to export contract to Marlowe Runner

changelog.d/20230922_035409_pablo.lamela_PLT_7427.md

@@ -0,0 +1,42 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Removed
+
+- A bullet item for the Removed category.
+
+-->
+
+### Added
+
+- Added button to export contracts to Marlowe Runner 
+
+
+<!--
+### Changed
+
+- A bullet item for the Changed category.
+
+-->
+<!--
+### Deprecated
+
+- A bullet item for the Deprecated category.
+
+-->
+<!--
+### Fixed
+
+- A bullet item for the Fixed category.
+
+-->
+<!--
+### Security
+
+- A bullet item for the Security category.
+
+-->

marlowe-playground-client/spago.dhall

@@ -41,6 +41,7 @@
   , "integers"
   , "js-object"
   , "js-timers"
+  , "js-uri"
   , "json-helpers"
   , "lists"
   , "markdown"

marlowe-playground-client/src/Component/Modal/View.purs

@@ -10,6 +10,7 @@ import Component.NewProject.View (render) as NewProject
 import Component.Projects.View (render) as Projects
 import Data.Lens ((^.))
 import Effect.Aff.Class (class MonadAff)
+import ExportToRunner (exportToRunnerForm)
 import GistButtons (authButton)
 import Halogen (ComponentHTML)
 import Halogen.Extra (renderSubmodule)
@@ -61,3 +62,5 @@ modal state = case state ^. _showModal of
       intendedAction
       state
     (GithubLogin intendedAction) -> authButton intendedAction state
+    (ExportToRunnerModal contractString) -> exportToRunnerForm contractString
+      state

marlowe-playground-client/src/ExportToRunner.purs

@@ -0,0 +1,38 @@
+module ExportToRunner (exportToRunnerForm) where
+
+import Prologue hiding (div)
+
+import Component.Modal.ViewHelpers (modalHeader)
+import Data.Tuple.Nested ((/\))
+import Gists.View (idPublishGist)
+import Halogen.Classes (modalContent)
+import Halogen.HTML (ClassName(..), HTML, a, div, div_, p, text)
+import Halogen.HTML.Events (onClick)
+import Halogen.HTML.Properties (classes)
+import MainFrame.Types (Action(..), State)
+
+exportToRunnerForm :: forall p. String -> State -> HTML p Action
+exportToRunnerForm contractString _state =
+  div_
+    [ modalHeader "Export to Marlowe Runner" (Just CloseModal)
+    , div [ classes [ modalContent ] ]
+        [ p [ classes [ ClassName "mb-3" ] ]
+            [ text
+                "On what network would you like to deploy the contract?"
+            ]
+        , div_
+            do
+              (title /\ url) <-
+                [ ("Mainnet" /\ "https://mainnet.runner.marlowe.iohk.io/")
+                , ("Preprod" /\ "https://preprod.runner.marlowe.iohk.io/")
+                , ("Preview" /\ "https://preview.runner.marlowe.iohk.io/")
+                ]
+              pure $ a
+                [ idPublishGist
+                , classes [ ClassName "auth-button", ClassName "mx-3" ]
+                , onClick $ const $ SendToRunner url contractString
+                ]
+                [ text title
+                ]
+        ]
+    ]

marlowe-playground-client/src/MainFrame/State.purs

@@ -16,6 +16,7 @@ import Control.Monad.Except (ExceptT(..), lift, runExceptT)
 import Control.Monad.Maybe.Extra (hoistMaybe)
 import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
 import Control.Monad.State (modify_)
+import Data.Argonaut (encodeJson, stringify)
 import Data.Argonaut.Extra (encodeStringifyJson, parseDecodeJson)
 import Data.Bifunctor (lmap)
 import Data.Either (either, hush, note)
@@ -30,18 +31,21 @@ import Data.RawJson (RawJson(..))
 import Effect.Aff.Class (class MonadAff, liftAff)
 import Effect.Class (class MonadEffect)
 import Effect.Class.Console (log)
+import Effect.Console as Console
 import Gist (Gist, gistDescription, gistId)
 import Gists.Extra (_GistId)
 import Gists.Types (GistAction(..))
 import Gists.Types (parseGistUrl) as Gists
 import Halogen (Component, liftEffect, subscribe')
 import Halogen as H
 import Halogen.Analytics (withAnalytics)
-import Halogen.Extra (mapSubmodule)
+import Halogen.Extra (imapState, mapSubmodule)
 import Halogen.Monaco (KeyBindings(DefaultBindings))
 import Halogen.Monaco as Monaco
 import Halogen.Query (HalogenM)
 import Halogen.Query.Event (eventListener)
+import JSURI (encodeURIComponent)
+import Language.Marlowe.Core.V1.Semantics.Types (Contract)
 import Language.Marlowe.Extended.V1.Metadata
   ( emptyContractMetadata
   , getHintsFromMetadata
@@ -83,6 +87,7 @@ import MainFrame.View (render)
 import Marlowe (Api, getApiGistsByGistId)
 import Marlowe as Server
 import Marlowe.Gists (PlaygroundFiles, mkNewGist, mkPatchGist, playgroundFiles)
+import Marlowe.Holes (fromTerm)
 import Network.RemoteData (RemoteData(..), _Success, fromEither)
 import Page.BlocklyEditor.State as BlocklyEditor
 import Page.BlocklyEditor.Types (_marloweCode)
@@ -122,9 +127,11 @@ import Simple.JSON (unsafeStringify)
 import StaticData (gistIdLocalStorageKey)
 import StaticData as StaticData
 import Types (WebpackBuildMode(..))
+import Web.HTML (window)
 import Web.HTML (window) as Web
 import Web.HTML.HTMLDocument (toEventTarget)
 import Web.HTML.Window (document) as Web
+import Web.HTML.Window (open)
 import Web.HTML.Window as Window
 import Web.UIEvent.KeyboardEvent as KE
 import Web.UIEvent.KeyboardEvent.EventTypes (keyup)
@@ -454,6 +461,18 @@ handleAction (SimulationAction action) = do
     ST.EditSource -> do
       mLang <- use _workflow
       for_ mLang \lang -> selectView $ selectLanguageView lang
+    ST.ExportToRunner -> do
+      result <- imapState _simulationState
+        ( runMaybeT $ do
+            extendedContract <- MaybeT Simulation.mkContract
+            coreContract :: Contract <- MaybeT $ pure $ fromTerm
+              extendedContract
+            pure $ stringify $ encodeJson coreContract
+        )
+      case result of
+        Just contract -> modify_
+          (set _showModal (Just $ ExportToRunnerModal contract))
+        Nothing -> pure unit
     _ -> pure unit
 
 handleAction (ChangeView view) = selectView view
@@ -623,6 +642,17 @@ handleAction (OpenModal modalView) = assign _showModal $ Just modalView
 
 handleAction CloseModal = assign _showModal Nothing
 
+handleAction (SendToRunner url contractString) = do
+  case encodeURIComponent contractString of
+    Just encodedContract -> do
+      let fullUrl = url <> "?contract=" <> encodedContract
+      liftEffect $ do
+        win <- window
+        void $ open fullUrl "_blank" "" win
+      handleAction CloseModal
+    Nothing -> do
+      liftEffect $ Console.error "Failed to encode contract string for URL."
+
 handleAction (OpenLoginPopup intendedAction) = do
   authRole <- liftAff openLoginPopup
   fullHandleAction CloseModal

marlowe-playground-client/src/MainFrame/Types.purs

@@ -57,6 +57,7 @@ data ModalView
   | SaveProjectAs
   | GithubLogin Action
   | ConfirmUnsavedNavigation Action
+  | ExportToRunnerModal String
 
 derive instance genericModalView :: Generic ModalView _
 
@@ -68,6 +69,7 @@ instance showModalView :: Show ModalView where
   show SaveProjectAs = "SaveProjectAs"
   show (ConfirmUnsavedNavigation _) = "ConfirmUnsavedNavigation"
   show (GithubLogin _) = "GithubLogin"
+  show (ExportToRunnerModal _) = "ExportToRunnerModal"
 
 -- Before adding the intended action to GithubLogin, this instance was being
 -- handled by the genericShow. Action does not have a show instance so genericShow
@@ -99,6 +101,7 @@ data Action
   | GistAction GistAction
   | OpenModal ModalView
   | CloseModal
+  | SendToRunner String String
   | OpenLoginPopup Action
 
 -- | Here we decide which top-level queries to track as GA events, and
@@ -127,6 +130,7 @@ instance actionIsEvent :: IsEvent Action where
     { category = Just "OpenModal" }
   toEvent CloseModal = Just $ defaultEvent "CloseModal"
   toEvent (OpenLoginPopup _) = Just $ defaultEvent "OpenLoginPopup"
+  toEvent (SendToRunner _ _) = Just $ defaultEvent "SendToRunner"
   toEvent Logout = Just $ defaultEvent "Logout"
 
 data View

marlowe-playground-client/src/Page/Simulation/State.purs

@@ -3,6 +3,7 @@ module Page.Simulation.State
   , editorGetValue
   , getCurrentContract
   , mkStateBase
+  , mkContract
   ) where
 
 import Prologue hiding (div)
@@ -126,11 +127,11 @@ toBottomPanel
 toBottomPanel = mapSubmodule _bottomPanelState BottomPanelAction
 
 mkContract
-  :: forall m
+  :: forall m a
    . MonadAff m
   => MonadEffect m
   => MonadAjax Api m
-  => HalogenM State Action ChildSlots Void m (Maybe (Term Term.Contract))
+  => HalogenM State a ChildSlots Void m (Maybe (Term Term.Contract))
 mkContract = runMaybeT do
   termContract <- MaybeT $ peruse
     ( _currentMarloweState
@@ -273,6 +274,8 @@ handleAction _ (ShowRightPanel val) = assign _showRightPanel val
 
 handleAction _ EditSource = pure unit
 
+handleAction _ ExportToRunner = pure unit
+
 stripPair :: String -> Boolean /\ String
 stripPair pair = case splitAt 4 pair of
   { before, after }

marlowe-playground-client/src/Page/Simulation/Types.purs

@@ -60,6 +60,7 @@ data Action
   | ShowRightPanel Boolean
   | BottomPanelAction (BottomPanel.Action BottomPanelView Action)
   | EditSource
+  | ExportToRunner
 
 defaultEvent :: String -> Event
 defaultEvent s = A.defaultEvent $ "Simulation." <> s
@@ -82,6 +83,7 @@ instance isEventAction :: IsEvent Action where
   toEvent (BottomPanelAction action) = A.toEvent action
   toEvent EditSource = Just $ defaultEvent "EditSource"
   toEvent (HandleEditorMessage _) = Just $ defaultEvent "HandleEditorMessage"
+  toEvent ExportToRunner = Just $ defaultEvent "ExportToRunner"
 
 data Query a = WebsocketResponse (RemoteData String Result) a
 

marlowe-playground-client/src/Page/Simulation/View.purs

@@ -89,7 +89,6 @@ import Halogen.HTML
   , section
   , slot
   , span
-  , span_
   , strong_
   , text
   , ul
@@ -395,6 +394,12 @@ startSimulationWidget
                 , onClick $ const DownloadAsJson
                 ]
                 [ text "Download as JSON" ]
+            , button
+                [ classNames
+                    [ "btn", "bold", "flex-1", "max-w-[15rem]", "mx-2" ]
+                , onClick $ const ExportToRunner
+                ]
+                [ text "Export to Marlowe Runner" ]
             , button
                 [ classNames
                     [ "btn", "bold", "flex-1", "max-w-[15rem]", "mx-2" ]