Merge pull request #52 from input-output-hk/PLT-8277

PLT-8277 - Add a button to copy to the clipboard a link to the current contract in the Marlowe editor

changelog.d/20231026_200217_pablo.lamela_PLT_8277.md

@@ -0,0 +1,41 @@
+<!--
+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 a button to copy to the clipboard a link to the current contract in the Marlowe editor
+
+<!--
+### 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/src/MainFrame/State.purs

@@ -259,7 +259,7 @@ handleSubRoute Router.MarloweEditor = selectView MarloweEditor
 
 handleSubRoute (Router.ImportContract contract) = do
   handleActionWithoutNavigationGuard
-    (MarloweEditorAction (ME.ImportCompressedJSON contract))
+    (MarloweEditorAction (ME.ImportCompressedContract contract))
   selectView MarloweEditor
 
 handleSubRoute Router.HaskellEditor = selectView HaskellEditor

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

@@ -11,6 +11,7 @@ import Component.BottomPanel.Types (Action(..), State) as BottomPanel
 import Control.Monad.Except (lift)
 import Control.Monad.Maybe.Extra (hoistMaybe)
 import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
+import Data.Argonaut (encodeJson, stringify)
 import Data.Argonaut.Extra (parseDecodeJson)
 import Data.Array as Array
 import Data.Either (hush)
@@ -19,11 +20,12 @@ import Data.Lens (assign, modifying, over, preview, set, use)
 import Data.Lens.Index (ix)
 import Data.Map as Map
 import Data.Map.Ordered.OMap as OMap
-import Data.Maybe (fromMaybe)
-import Data.String (Pattern(..), codePointFromChar, contains)
+import Data.Maybe (fromMaybe, maybe)
+import Data.String (Pattern(..), codePointFromChar, contains, length, splitAt)
 import Data.String as String
 import Data.Time.Duration (Minutes(..))
 import Effect.Aff.Class (class MonadAff, liftAff)
+import Effect.Console (error)
 import Effect.Now (now)
 import Examples.Marlowe.Contracts (example) as ME
 import Halogen (HalogenM, liftEffect, modify_, query)
@@ -57,6 +59,8 @@ import Page.MarloweEditor.Types
   , _selectedHole
   , _showErrorDetail
   )
+import Router (SubRoute(..)) as Route
+import Router (printSubRoute)
 import Servant.PureScript (class MonadAjax)
 import SessionStorage as SessionStorage
 import StaticAnalysis.Reachability
@@ -73,7 +77,9 @@ import StaticAnalysis.Types
 import StaticData (marloweBufferLocalStorageKey)
 import StaticData as StaticData
 import Text.Pretty (pretty)
-import Web.Blob.CompressString (decompressFromURI)
+import Web.Blob.Clipboard (copyToClipboard)
+import Web.Blob.CompressString (compressToURI, decompressFromURI)
+import Web.Blob.Window (getUrl)
 import Web.Event.Extra (preventDefault, readFileFromDragEvent)
 
 toBottomPanel
@@ -145,12 +151,14 @@ handleAction _ (LoadScript key) = do
 
 handleAction _ (SetEditorText contents) = editorSetValue contents
 
-handleAction _ (ImportCompressedJSON contents) = do
+handleAction _ (ImportCompressedContract contents) = do
   let
-    decodedContract = case parseDecodeJson (decompressFromURI contents) of
-      Right contract -> contract
-      Left _ -> Extended.Close
-    termContract = toTerm decodedContract :: Holes.Term Holes.Contract
+    decompressedInput = decompressFromURI contents
+    termContract = case parseDecodeJson decompressedInput of
+      Right contract -> toTerm (contract :: Extended.Contract)
+      Left _ -> case parseContract decompressedInput of
+        Right hcontract -> hcontract
+        Left _ -> toTerm Extended.Close
     prettyContents = show $ pretty termContract
   editorSetValue prettyContents
   liftEffect $ SessionStorage.setItem marloweBufferLocalStorageKey
@@ -170,6 +178,38 @@ handleAction _ SendToSimulator = pure unit
 
 handleAction _ ViewAsBlockly = pure unit
 
+handleAction _ CopyContractLink = do
+  url <- liftEffect getUrl
+  mResult <-
+    ( runMaybeT $ do
+        contents <- MaybeT $ editorGetValue
+        encodedContract <- hoistMaybe $ maybe
+          (show <$> (hush $ parseContract contents))
+          (Just <<< stringify <<< encodeJson)
+          (parseContract' contents)
+        let compressedContract = compressToURI encodedContract
+        hoistMaybe $ composeURL url compressedContract
+    )
+  case mResult of
+    Just result -> liftAff $ copyToClipboard result
+    Nothing -> liftEffect $ error "Could not encode contract as a link"
+
+  where
+  composeURL :: String -> String -> Maybe String
+  composeURL url compCont = do
+    baseUrl <- removeSuffix url (printSubRoute Route.MarloweEditor)
+    pure $ baseUrl <> (printSubRoute (Route.ImportContract compCont))
+
+  removeSuffix :: String -> String -> Maybe String
+  removeSuffix str suffix =
+    let
+      { before: strPrefix, after: strSuffix } = splitAt
+        (length str - length suffix)
+        str
+    in
+      if strSuffix == suffix then Just $ strPrefix
+      else Nothing
+
 handleAction _ (InitMarloweProject contents) = do
   editorSetValue contents
   liftEffect $ SessionStorage.setItem marloweBufferLocalStorageKey contents

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

@@ -32,11 +32,12 @@ data Action
   | MoveToPosition Pos Pos
   | LoadScript String
   | SetEditorText String
-  | ImportCompressedJSON String
+  | ImportCompressedContract String
   | BottomPanelAction (BottomPanel.Action BottomPanelView Action)
   | ShowErrorDetail Boolean
   | SendToSimulator
   | ViewAsBlockly
+  | CopyContractLink
   | InitMarloweProject String
   | SelectHole (Maybe String)
   | MetadataAction MetadataAction
@@ -60,11 +61,13 @@ instance actionIsEvent :: IsEvent Action where
   toEvent (LoadScript script) = Just $ (defaultEvent "LoadScript")
     { label = Just script }
   toEvent (SetEditorText _) = Just $ defaultEvent "SetEditorText"
-  toEvent (ImportCompressedJSON _) = Just $ defaultEvent "ImportCompressedJSON"
+  toEvent (ImportCompressedContract _) = Just $ defaultEvent
+    "ImportCompressedContract"
   toEvent (BottomPanelAction action) = A.toEvent action
   toEvent (ShowErrorDetail _) = Just $ defaultEvent "ShowErrorDetail"
   toEvent SendToSimulator = Just $ defaultEvent "SendToSimulator"
   toEvent ViewAsBlockly = Just $ defaultEvent "ViewAsBlockly"
+  toEvent CopyContractLink = Just $ defaultEvent "CopyContractLink"
   toEvent (InitMarloweProject _) = Just $ defaultEvent "InitMarloweProject"
   toEvent (SelectHole _) = Just $ defaultEvent "SelectHole"
   toEvent (MetadataAction action) = Just $ (defaultEvent "MetadataAction")

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

@@ -1,4 +1,8 @@
-module Page.MarloweEditor.View where
+module Page.MarloweEditor.View
+  ( otherActions
+  , render
+  , sendToSimulatorButton
+  ) where
 
 import Prologue hiding (div)
 
@@ -92,6 +96,7 @@ otherActions
 otherActions state =
   div [ classes [ group ] ]
     [ editorOptions state
+    , copyLink state
     , viewAsBlocklyButton state
     , sendToSimulatorButton state
     ]
@@ -141,6 +146,30 @@ viewAsBlocklyButton state =
     else
       []
 
+copyLink
+  :: forall m
+   . MonadAff m
+  => State
+  -> ComponentHTML Action ChildSlots m
+copyLink state =
+  div [ HP.id "copyContractLink", classNames [ "relative" ] ]
+    [ button
+        [ onClick $ const CopyContractLink
+        , disabled disabled'
+        , classNames [ "btn" ]
+        ]
+        [ text "Copy Link" ]
+    , tooltip tooltipMessage (RefId "copyContractLink") Bottom
+    ]
+  where
+  disabled' = contractHasErrors state
+
+  tooltipMessage =
+    if disabled' then
+      "A contract link can only be generated if the contract has no errors"
+    else
+      "Copy a link to the Marlowe editor with the current contract encoded in the URL"
+
 editorOptions :: forall p. State -> HTML p Action
 editorOptions state =
   div [ class_ (ClassName "editor-options") ]

marlowe-playground-client/src/Router.purs

@@ -7,6 +7,7 @@ import Data.Newtype (unwrap)
 import Data.Profunctor (dimap)
 import Gists.Extra (GistId(..))
 import Routing.Duplex (RouteDuplex', optional, param, record, root, (:=))
+import Routing.Duplex as Route
 import Routing.Duplex.Generic (noArgs, sum)
 import Routing.Duplex.Generic.Syntax ((/))
 import Type.Proxy (Proxy(..))
@@ -52,3 +53,6 @@ route =
   _gistId = Proxy :: _ "gistId"
 
   _subroute = Proxy :: _ "subroute"
+
+printSubRoute :: SubRoute -> String
+printSubRoute sr = Route.print route { gistId: Nothing, subroute: sr }

marlowe-playground-client/src/Web/Blob/Clipboard.js

@@ -0,0 +1,5 @@
+"use strict";
+
+export function copyToClipboardImpl(text, onFulfilled, onRejected) {
+  return navigator.clipboard.writeText(text);
+};

marlowe-playground-client/src/Web/Blob/Clipboard.purs

@@ -0,0 +1,12 @@
+module Web.Blob.Clipboard (copyToClipboard) where
+
+import Prelude
+
+import Control.Promise (Promise, toAffE)
+import Effect.Aff (Aff)
+import Effect.Uncurried (EffectFn1, runEffectFn1)
+
+foreign import copyToClipboardImpl :: EffectFn1 String (Promise Unit)
+
+copyToClipboard :: String -> Aff Unit
+copyToClipboard str = toAffE (runEffectFn1 copyToClipboardImpl str)

marlowe-playground-client/src/Web/Blob/Window.js

@@ -0,0 +1,6 @@
+"use strict";
+
+export function getUrlImpl() {
+    return window.location.href;
+};
+

marlowe-playground-client/src/Web/Blob/Window.purs

@@ -0,0 +1,11 @@
+module Web.Blob.Window (getUrl) where
+
+import Prelude
+
+import Effect (Effect)
+import Effect.Uncurried (EffectFn1, runEffectFn1)
+
+foreign import getUrlImpl :: EffectFn1 Unit String
+
+getUrl :: Effect String
+getUrl = runEffectFn1 getUrlImpl unit