Skip to content

Commit

Permalink
PLT-8277 - Add a button to copy to the clipboard a link to the curren…
Browse files Browse the repository at this point in the history
…t contract in the Marlowe editor
  • Loading branch information
palas committed Oct 27, 2023
1 parent 01ed6b8 commit 7fdd15d
Show file tree
Hide file tree
Showing 9 changed files with 148 additions and 3 deletions.
41 changes: 41 additions & 0 deletions changelog.d/20231026_200217_pablo.lamela_PLT_8277.md
Original file line number Diff line number Diff line change
@@ -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.
-->
39 changes: 37 additions & 2 deletions marlowe-playground-client/src/Page/MarloweEditor/State.purs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -20,10 +21,11 @@ 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.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)
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -170,6 +176,35 @@ handleAction _ SendToSimulator = pure unit

handleAction _ ViewAsBlockly = pure unit

handleAction _ CopyContractLink = do
url <- liftEffect getUrl
mResult <-
( runMaybeT $ do
contents <- MaybeT $ editorGetValue
contract <- hoistMaybe $ parseContract' contents
let compressedContract = compressToURI $ stringify $ encodeJson contract
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
Expand Down
2 changes: 2 additions & 0 deletions marlowe-playground-client/src/Page/MarloweEditor/Types.purs
Original file line number Diff line number Diff line change
Expand Up @@ -37,6 +37,7 @@ data Action
| ShowErrorDetail Boolean
| SendToSimulator
| ViewAsBlockly
| CopyContractLink
| InitMarloweProject String
| SelectHole (Maybe String)
| MetadataAction MetadataAction
Expand Down Expand Up @@ -65,6 +66,7 @@ instance actionIsEvent :: IsEvent Action where
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")
Expand Down
31 changes: 30 additions & 1 deletion marlowe-playground-client/src/Page/MarloweEditor/View.purs
Original file line number Diff line number Diff line change
@@ -1,4 +1,8 @@
module Page.MarloweEditor.View where
module Page.MarloweEditor.View
( otherActions
, render
, sendToSimulatorButton
) where

import Prologue hiding (div)

Expand Down Expand Up @@ -92,6 +96,7 @@ otherActions
otherActions state =
div [ classes [ group ] ]
[ editorOptions state
, copyLink state
, viewAsBlocklyButton state
, sendToSimulatorButton state
]
Expand Down Expand Up @@ -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 || contractHasHoles state

tooltipMessage =
if disabled' then
"A contract link can only be generated if the contract has no errors and no holes"
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") ]
Expand Down
4 changes: 4 additions & 0 deletions marlowe-playground-client/src/Router.purs
Original file line number Diff line number Diff line change
Expand Up @@ -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(..))
Expand Down Expand Up @@ -52,3 +53,6 @@ route =
_gistId = Proxy :: _ "gistId"

_subroute = Proxy :: _ "subroute"

printSubRoute :: SubRoute -> String
printSubRoute sr = Route.print route { gistId: Nothing, subroute: sr }
5 changes: 5 additions & 0 deletions marlowe-playground-client/src/Web/Blob/Clipboard.js
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
"use strict";

export function copyToClipboardImpl(text, onFulfilled, onRejected) {
return navigator.clipboard.writeText(text);
};
12 changes: 12 additions & 0 deletions marlowe-playground-client/src/Web/Blob/Clipboard.purs
Original file line number Diff line number Diff line change
@@ -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)
6 changes: 6 additions & 0 deletions marlowe-playground-client/src/Web/Blob/Window.js
Original file line number Diff line number Diff line change
@@ -0,0 +1,6 @@
"use strict";

export function getUrlImpl() {
return window.location.href;
};

11 changes: 11 additions & 0 deletions marlowe-playground-client/src/Web/Blob/Window.purs
Original file line number Diff line number Diff line change
@@ -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

0 comments on commit 7fdd15d

Please sign in to comment.