From 5f39433c79e5c1c4412381ba4e1c1f479de04fdd Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Wed, 20 Sep 2023 22:20:01 +0200 Subject: [PATCH 1/6] Remove unused import --- marlowe-playground-client/src/Page/Simulation/View.purs | 1 - 1 file changed, 1 deletion(-) diff --git a/marlowe-playground-client/src/Page/Simulation/View.purs b/marlowe-playground-client/src/Page/Simulation/View.purs index 43d17709c..7fa12cd5c 100644 --- a/marlowe-playground-client/src/Page/Simulation/View.purs +++ b/marlowe-playground-client/src/Page/Simulation/View.purs @@ -89,7 +89,6 @@ import Halogen.HTML , section , slot , span - , span_ , strong_ , text , ul From a33f59bedf190e857e7ce27f48baf4138ec247c0 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Thu, 21 Sep 2023 20:21:21 +0200 Subject: [PATCH 2/6] Add dummy button --- marlowe-playground-client/src/Page/Simulation/State.purs | 2 ++ marlowe-playground-client/src/Page/Simulation/Types.purs | 2 ++ marlowe-playground-client/src/Page/Simulation/View.purs | 6 ++++++ 3 files changed, 10 insertions(+) diff --git a/marlowe-playground-client/src/Page/Simulation/State.purs b/marlowe-playground-client/src/Page/Simulation/State.purs index edf8717ec..c12ef4c2c 100644 --- a/marlowe-playground-client/src/Page/Simulation/State.purs +++ b/marlowe-playground-client/src/Page/Simulation/State.purs @@ -273,6 +273,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 } diff --git a/marlowe-playground-client/src/Page/Simulation/Types.purs b/marlowe-playground-client/src/Page/Simulation/Types.purs index 5ab37bd6e..d4ed1657a 100644 --- a/marlowe-playground-client/src/Page/Simulation/Types.purs +++ b/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 diff --git a/marlowe-playground-client/src/Page/Simulation/View.purs b/marlowe-playground-client/src/Page/Simulation/View.purs index 7fa12cd5c..4a1890fa4 100644 --- a/marlowe-playground-client/src/Page/Simulation/View.purs +++ b/marlowe-playground-client/src/Page/Simulation/View.purs @@ -394,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" ] From 0cfaafcaf3f3a00b9a9564f32f2f6b58eb407880 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Fri, 22 Sep 2023 03:12:39 +0200 Subject: [PATCH 3/6] Add dummy scafolding and wiring of export to Marlowe Runner --- .../src/Component/Modal/View.purs | 3 ++ .../src/ExportToRunner.purs | 38 +++++++++++++++++++ .../src/MainFrame/State.purs | 20 +++++++++- .../src/MainFrame/Types.purs | 4 ++ .../src/Page/Simulation/State.purs | 5 ++- 5 files changed, 67 insertions(+), 3 deletions(-) create mode 100644 marlowe-playground-client/src/ExportToRunner.purs diff --git a/marlowe-playground-client/src/Component/Modal/View.purs b/marlowe-playground-client/src/Component/Modal/View.purs index ce66aaf5f..3e6711c98 100644 --- a/marlowe-playground-client/src/Component/Modal/View.purs +++ b/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 diff --git a/marlowe-playground-client/src/ExportToRunner.purs b/marlowe-playground-client/src/ExportToRunner.purs new file mode 100644 index 000000000..1b4778804 --- /dev/null +++ b/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" /\ "") + , ("Preprod" /\ "") + , ("Preview" /\ "") + ] + pure $ a + [ idPublishGist + , classes [ ClassName "auth-button", ClassName "mx-3" ] + , onClick $ const $ SendToRunner url contractString + ] + [ text title + ] + ] + ] diff --git a/marlowe-playground-client/src/MainFrame/State.purs b/marlowe-playground-client/src/MainFrame/State.purs index 981edd848..871c9427e 100644 --- a/marlowe-playground-client/src/MainFrame/State.purs +++ b/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) @@ -37,11 +38,12 @@ 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 Language.Marlowe.Core.V1.Semantics.Types (Contract) import Language.Marlowe.Extended.V1.Metadata ( emptyContractMetadata , getHintsFromMetadata @@ -83,6 +85,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) @@ -454,6 +457,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 +638,9 @@ handleAction (OpenModal modalView) = assign _showModal $ Just modalView handleAction CloseModal = assign _showModal Nothing +handleAction (SendToRunner _url _contractString) = do + handleAction CloseModal + handleAction (OpenLoginPopup intendedAction) = do authRole <- liftAff openLoginPopup fullHandleAction CloseModal diff --git a/marlowe-playground-client/src/MainFrame/Types.purs b/marlowe-playground-client/src/MainFrame/Types.purs index 1956388b8..01254c4fe 100644 --- a/marlowe-playground-client/src/MainFrame/Types.purs +++ b/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 diff --git a/marlowe-playground-client/src/Page/Simulation/State.purs b/marlowe-playground-client/src/Page/Simulation/State.purs index c12ef4c2c..6514382f4 100644 --- a/marlowe-playground-client/src/Page/Simulation/State.purs +++ b/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 From 8d91aa3f1c15174a8de22200929c39527f20567f Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Fri, 22 Sep 2023 03:53:31 +0200 Subject: [PATCH 4/6] Implement connection to Marlowe Runner --- .../src/ExportToRunner.purs | 6 +++--- .../src/MainFrame/State.purs | 16 ++++++++++++++-- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/marlowe-playground-client/src/ExportToRunner.purs b/marlowe-playground-client/src/ExportToRunner.purs index 1b4778804..0ad13dd3c 100644 --- a/marlowe-playground-client/src/ExportToRunner.purs +++ b/marlowe-playground-client/src/ExportToRunner.purs @@ -23,9 +23,9 @@ exportToRunnerForm contractString _state = , div_ do (title /\ url) <- - [ ("Mainnet" /\ "") - , ("Preprod" /\ "") - , ("Preview" /\ "") + [ ("Mainnet" /\ "https://mainnet.runner.marlowe.iohk.io/") + , ("Preprod" /\ "https://preprod.runner.marlowe.iohk.io/") + , ("Preview" /\ "https://preview.runner.marlowe.iohk.io/") ] pure $ a [ idPublishGist diff --git a/marlowe-playground-client/src/MainFrame/State.purs b/marlowe-playground-client/src/MainFrame/State.purs index 871c9427e..7d92fcb60 100644 --- a/marlowe-playground-client/src/MainFrame/State.purs +++ b/marlowe-playground-client/src/MainFrame/State.purs @@ -31,6 +31,7 @@ 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(..)) @@ -43,6 +44,7 @@ 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 @@ -125,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) @@ -638,8 +642,16 @@ handleAction (OpenModal modalView) = assign _showModal $ Just modalView handleAction CloseModal = assign _showModal Nothing -handleAction (SendToRunner _url _contractString) = do - handleAction CloseModal +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 From 5d9f92fd14a71d25b83896867d0a9c3e688dd415 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Fri, 22 Sep 2023 03:55:20 +0200 Subject: [PATCH 5/6] Added changelog entry --- .../20230922_035409_pablo.lamela_PLT_7427.md | 42 +++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 changelog.d/20230922_035409_pablo.lamela_PLT_7427.md diff --git a/changelog.d/20230922_035409_pablo.lamela_PLT_7427.md b/changelog.d/20230922_035409_pablo.lamela_PLT_7427.md new file mode 100644 index 000000000..cb6a7efb8 --- /dev/null +++ b/changelog.d/20230922_035409_pablo.lamela_PLT_7427.md @@ -0,0 +1,42 @@ + + + + +### Added + +- Added button to export contracts to Marlowe Runner + + + + + + From 1458d99f75ee354da1aa3657ef1c7f6bf0866269 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Fri, 22 Sep 2023 04:27:09 +0200 Subject: [PATCH 6/6] Add js-uri to spago --- marlowe-playground-client/spago.dhall | 1 + 1 file changed, 1 insertion(+) diff --git a/marlowe-playground-client/spago.dhall b/marlowe-playground-client/spago.dhall index 678b51546..c6b65db8e 100644 --- a/marlowe-playground-client/spago.dhall +++ b/marlowe-playground-client/spago.dhall @@ -41,6 +41,7 @@ , "integers" , "js-object" , "js-timers" + , "js-uri" , "json-helpers" , "lists" , "markdown"