Load contracts from query parameter - PLT-6093

spago.dhall

@@ -20,8 +20,10 @@
   , "effect"
   , "either"
   , "enums"
+  , "errors"
   , "exceptions"
   , "foldable-traversable"
+  , "foreign-generic"
   , "foreign-object"
   , "formatters"
   , "free"

src/Component/App.purs

@@ -6,7 +6,8 @@ import CardanoMultiplatformLib.Types (Bech32)
 import Component.Assets.Svgs (marloweLogoUrl)
 import Component.ConnectWallet (mkConnectWallet, walletInfo)
 import Component.ConnectWallet as ConnectWallet
-import Component.ContractList (mkContractList)
+import Component.ContractList (ModalAction(..), mkContractList)
+import Component.CreateContract (ContractJsonString)
 import Component.Footer (footer)
 import Component.Footer as Footer
 import Component.LandingPage (mkLandingPage)
@@ -117,7 +118,9 @@ newtype AppContractInfoMap = AppContractInfoMap
   , map :: ContractInfoMap
   }
 
-mkApp :: MkComponentMBase () (Unit -> JSX)
+type Props = { possibleInitialContract :: Maybe ContractJsonString }
+
+mkApp :: MkComponentMBase () (Props -> JSX)
 mkApp = do
   landingPage <- mkLandingPage
   messageBox <- liftEffect $ mkMessageBox
@@ -136,7 +139,7 @@ mkApp = do
   about <- asks _.aboutMarkdown
   Runtime runtime <- asks _.runtime
 
-  liftEffect $ component "App" \_ -> React.do
+  liftEffect $ component "App" \props -> React.do
     possibleWalletInfo /\ setWalletInfo <- useState' Nothing
     let
       walletInfoName = _.name <<< un WalletInfo <$> possibleWalletInfo
@@ -336,6 +339,7 @@ mkApp = do
               -- if version == initialVersion then Nothing
               -- else Just contractArray
               , connectedWallet: possibleWalletInfo
+              , possibleInitialModalAction: (NewContract <<< Just) <$> props.possibleInitialContract
               }
         -- renderTab props children = tab props $ DOM.div { className: "row pt-4" } children
 

src/Component/ContractList.purs

@@ -11,7 +11,7 @@ import Component.ContractDetails as ContractDetails
 import Component.ContractTemplates.ContractForDifferencesWithOracle as ContractForDifferencesWithOracle
 import Component.ContractTemplates.Escrow as Escrow
 import Component.ContractTemplates.Swap as Swap
-import Component.CreateContract (runLiteTag)
+import Component.CreateContract (ContractJsonString(..), runLiteTag)
 import Component.CreateContract as CreateContract
 import Component.Types (ContractInfo(..), MessageContent(..), MessageHub(..), MkComponentM, Slotting(..), WalletInfo)
 import Component.Types.ContractInfo (MarloweInfo(..))
@@ -47,7 +47,7 @@ import Data.List (intercalate)
 import Data.List as List
 import Data.Map as Map
 import Data.Maybe (Maybe(..), fromMaybe, isNothing)
-import Data.Newtype (un)
+import Data.Newtype (class Newtype, un)
 import Data.Set as Set
 import Data.String (contains, length)
 import Data.String.Pattern (Pattern(..))
@@ -81,7 +81,7 @@ import ReactBootstrap.Table (striped) as Table
 import ReactBootstrap.Table (table)
 import ReactBootstrap.Types (placement)
 import ReactBootstrap.Types as OverlayTrigger
-import Utils.React.Basic.Hooks (useMaybeValue', useStateRef')
+import Utils.React.Basic.Hooks (useMaybeValue, useMaybeValue', useStateRef')
 import Wallet as Wallet
 import WalletContext (WalletContext(..))
 import Web.Clipboard (clipboard)
@@ -107,11 +107,12 @@ useInput initialValue = React.do
 
 type SubmissionError = String
 
-type ContractListState = { modalAction :: Maybe ModalAction }
+type ContractListState = { possibleInitialModalAction :: Maybe ModalAction }
 
 type Props =
   { possibleContracts :: Maybe (Array ContractInfo) -- `Maybe` indicates if the contracts where fetched already
   , connectedWallet :: Maybe (WalletInfo Wallet.Api)
+  , possibleInitialModalAction :: Maybe ModalAction
   }
 
 data OrderBy
@@ -133,7 +134,7 @@ data ContractTemplate = Escrow | Swap | ContractForDifferencesWithOracle
 derive instance Eq ContractTemplate
 
 data ModalAction
-  = NewContract
+  = NewContract (Maybe ContractJsonString)
   | ContractDetails
       { contract :: Maybe V1.Contract
       , state :: Maybe V1.State
@@ -189,10 +190,10 @@ mkContractList = do
   swapComponent <- Swap.mkComponent
   contractForDifferencesWithOracleComponent <- ContractForDifferencesWithOracle.mkComponent
 
-  liftEffect $ component "ContractList" \{ connectedWallet, possibleContracts } -> React.do
+  liftEffect $ component "ContractList" \{ connectedWallet, possibleInitialModalAction, possibleContracts } -> React.do
     possibleWalletContext <- useContext walletInfoCtx <#> map (un WalletContext <<< snd)
 
-    possibleModalAction /\ setModalAction /\ resetModalAction <- useMaybeValue'
+    possibleModalAction /\ setModalAction /\ resetModalAction <- useMaybeValue possibleInitialModalAction
     possibleModalActionRef <- useStateRef' possibleModalAction
     ordering /\ updateOrdering <- useState { orderBy: OrderByCreationDate, orderAsc: false }
     possibleQueryValue /\ setQueryValue <- useState' Nothing
@@ -239,7 +240,7 @@ mkContractList = do
 
     pure $
       case possibleModalAction, connectedWallet of
-        Just NewContract, Just cw -> createContractComponent
+        Just (NewContract possibleInitialContract), Just cw -> createContractComponent
           { connectedWallet: cw
           , onDismiss: resetModalAction
           , onSuccess: \_ -> do
@@ -248,6 +249,7 @@ mkContractList = do
                 , "Contract status should change to 'Confirmed' at that point."
                 ]
               resetModalAction
+          , possibleInitialContract
           }
         Just (ApplyInputs transactionsEndpoint marloweContext), Just cw -> do
           let
@@ -317,7 +319,7 @@ mkContractList = do
                       , disabled
                       , onClick: do
                           readRef possibleModalActionRef >>= case _ of
-                            Nothing -> setModalAction NewContract
+                            Nothing -> setModalAction (NewContract Nothing)
                             _ -> pure unit
                       }
                     templateContractButton = dropdownButton

src/Component/CreateContract.purs

@@ -21,6 +21,7 @@ import Contrib.Polyform.FormSpecs.StatelessFormSpec as StatlessFormSpec
 import Contrib.React.Basic.Hooks.UseMooreMachine (useMooreMachine)
 import Contrib.ReactBootstrap.FormSpecBuilders.StatelessFormSpecBuilders (StatelessBootstrapFormSpec, booleanField)
 import Contrib.ReactBootstrap.FormSpecBuilders.StatelessFormSpecBuilders as StatelessFormSpecBuilders
+import Control.Error.Util (hoistMaybe)
 import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
 import Control.Monad.Reader.Class (asks)
 import Control.Promise (Promise)
@@ -32,21 +33,21 @@ import Data.Bifunctor (lmap)
 import Data.BigInt.Argonaut (BigInt)
 import Data.BigInt.Argonaut as BigInt
 import Data.DateTime.Instant (Instant, instant, unInstant)
-import Data.Either (Either(..), hush)
+import Data.Either (Either(..), fromRight, hush)
 import Data.Foldable as Foldable
 import Data.FormURLEncoded.Query (FieldId(..), Query)
 import Data.Identity (Identity)
 import Data.Int as Int
 import Data.Map as Map
 import Data.Maybe (Maybe(..), fromMaybe, isJust)
 import Data.Monoid.Disj (Disj(..))
-import Data.Newtype (un)
+import Data.Newtype (class Newtype, un)
 import Data.Nullable (Nullable)
 import Data.Nullable as Nullable
 import Data.String (Pattern(..), split, trim)
 import Data.Time.Duration (Milliseconds(..), Seconds(..))
 import Data.Traversable (for)
-import Data.Tuple (snd)
+import Data.Tuple (fst, snd)
 import Data.Tuple.Nested (type (/\))
 import Data.Validation.Semigroup (V(..))
 import Debug (traceM)
@@ -56,8 +57,9 @@ import Effect.Class (liftEffect)
 import Effect.Now (now)
 import JS.Unsafe.Stringify (unsafeStringify)
 import Language.Marlowe.Core.V1.Semantics.Types as V1
-import Marlowe.Runtime.Web.Client (ClientError)
+import Marlowe.Runtime.Web.Client (ClientError, uriOpts)
 import Marlowe.Runtime.Web.Types (ContractEndpoint, PostContractsError, RoleTokenConfig(..), RolesConfig(..), Tags(..))
+import Parsing as Parsing
 import Partial.Unsafe (unsafeCrashWith)
 import Polyform.Validator (liftFn)
 import Polyform.Validator (liftFnEither, liftFnMMaybe) as Validator
@@ -78,11 +80,26 @@ import Web.File.FileList (FileList)
 import Web.File.FileList as FileList
 import Web.HTML.HTMLInputElement (HTMLInputElement)
 import Web.HTML.HTMLInputElement as HTMLInputElement
+import URI (RelativeRef(..), URI(..)) as URI
+import URI.Extra.QueryPairs (QueryPairs(..), keyFromString, keyToString, valueFromString, valueToString) as URI
+import URI.Extra.QueryPairs as URI.QueryPairs
+import URI.HostPortPair (HostPortPair) as URI
+import URI.HostPortPair as HostPortPair
+import URI.URIRef (Fragment, HierPath, Host, Path, Port, RelPath, URIRefOptions, UserInfo) as URI
+import URI.URIRef as URIRef
+import Web.HTML (window)
+import Web.HTML.Location as Location
+import Web.HTML.Window as Window
+
+newtype ContractJsonString = ContractJsonString String
+derive instance Eq ContractJsonString
+derive instance Newtype ContractJsonString _
 
 type Props =
   { onDismiss :: Effect Unit
   , onSuccess :: ContractEndpoint -> Effect Unit
   , connectedWallet :: WalletInfo Wallet.Api
+  , possibleInitialContract :: Maybe ContractJsonString
   }
 
 newtype AutoRun = AutoRun Boolean
@@ -100,7 +117,7 @@ autoRunFieldId = FieldId "auto-run"
 
 type LabeledFormSpec validatorM = StatelessFormSpec validatorM (Array (FieldId /\ JSX)) String
 
-mkContractFormSpec :: (Maybe V1.Contract /\ AutoRun) -> LabeledFormSpec Effect Query Result
+mkContractFormSpec :: (Maybe ContractJsonString /\ AutoRun) -> LabeledFormSpec Effect Query Result
 mkContractFormSpec (possibleInitialContract /\ (AutoRun initialAutoRun)) = FormSpecBuilder.evalBuilder Nothing $ do
   let
     -- We put subforms JSX into a Map so we can control rendering order etc.
@@ -120,7 +137,7 @@ mkContractFormSpec (possibleInitialContract /\ (AutoRun initialAutoRun)) = FormS
       { missingError: "Please provide contract terms JSON value"
       , initial: case possibleInitialContract of
           Nothing -> ""
-          Just initialContract -> stringifyWithIndent 2 $ encodeJson initialContract
+          Just (ContractJsonString initialContract) -> formatPossibleJSON initialContract
       , label: Just $ DOOM.text "Contract JSON"
       , touched: isJust possibleInitialContract
       , validator: requiredV' $ Validator.liftFnEither \jsonString -> do
@@ -175,8 +192,10 @@ type ClientError' = ClientError PostContractsError
 
 foreign import _loadFile :: File -> Promise (Nullable String)
 
-hoistMaybe :: forall m a. Applicative m => Maybe a -> MaybeT m a
-hoistMaybe = MaybeT <<< pure
+formatPossibleJSON :: String -> String
+formatPossibleJSON str = fromMaybe str do
+  json <- hush $ jsonParser str
+  pure $ stringifyWithIndent 2 $ encodeJson json
 
 mkLoadFileHiddenInputComponent :: MkComponentM ({ onFileload :: Maybe String -> Effect Unit, id :: String, accept :: String } -> JSX)
 mkLoadFileHiddenInputComponent =
@@ -299,14 +318,14 @@ mkComponent = do
   roleTokenComponent <- mkRoleTokensComponent
   loadFileHiddenInputComponent <- mkLoadFileHiddenInputComponent
 
-  liftEffect $ component "CreateContract" \{ connectedWallet, onSuccess, onDismiss } -> React.do
+  liftEffect $ component "CreateContract" \{ connectedWallet, onSuccess, onDismiss, possibleInitialContract } -> React.do
     currentRun /\ setCurrentRun <- React.useState' Nothing
     { state: submissionState, applyAction, reset: resetStateMachine } <- do
       let
         props = machineProps initialAutoRun connectedWallet cardanoMultiplatformLib runtime
       useMooreMachine props
 
-    formSpec <- React.useMemo unit \_ -> mkContractFormSpec (Nothing /\ initialAutoRun)
+    formSpec <- React.useMemo unit \_ -> mkContractFormSpec (possibleInitialContract /\ initialAutoRun)
 
     let
       onSubmit :: _ -> Effect Unit
@@ -362,9 +381,7 @@ mkComponent = do
                             allFields = formState.fields
                           void $ for (Map.lookup contractFieldId allFields) \{ onChange } -> do
                             let
-                              str' = fromMaybe str do
-                                json <- hush $ jsonParser str
-                                pure $ stringifyWithIndent 2 $ encodeJson json
+                              str' = formatPossibleJSON str
                             onChange [str']
 
                         Nothing -> traceM "No file"
@@ -422,7 +439,12 @@ mkComponent = do
         BodyLayout.component
           { title: stateToTitle submissionState
           , description: stateToDetailedDescription submissionState
-          , content: roleTokenComponent { onDismiss: pure unit, onSuccess: onSuccess', connectedWallet, roleNames }
+          , content: roleTokenComponent
+              { onDismiss
+              , onSuccess: onSuccess'
+              , connectedWallet
+              , roleNames
+              }
           }
       Machine.ContractCreated { contract, createTxResponse } -> do
         let

src/Main.purs

@@ -4,33 +4,48 @@ import Prelude
 
 import CardanoMultiplatformLib as CardanoMultiplatformLib
 import Component.App (mkApp)
+import Component.CreateContract (ContractJsonString(..))
 import Component.MessageHub (mkMessageHub)
 import Component.Types (Slotting(..))
 import Contrib.Data.Argonaut (JsonParser)
 import Contrib.Effect as Effect
 import Contrib.JsonBigInt as JsonBigInt
 import Control.Monad.Reader (runReaderT)
 import Data.Argonaut (Json, decodeJson, (.:))
+import Data.Array as Array
 import Data.BigInt.Argonaut as BigInt
-import Data.Either (Either(..))
-import Data.Maybe (Maybe(..), fromJust, maybe)
+import Data.Either (Either(..), hush)
+import Data.Foldable as Foldable
+import Data.Maybe (Maybe(..), fromJust, fromMaybe, maybe)
+import Data.Tuple (fst)
 import Data.Tuple.Nested ((/\))
 import Effect (Effect)
 import Effect.Aff (launchAff_)
 import Effect.Class (liftEffect)
 import Effect.Class.Console as Console
 import Effect.Exception (throw)
+import Foreign.NullOrUndefined (null) as Foreign
 import JS.Unsafe.Stringify (unsafeStringify)
 import Marlowe.Runtime.Web as Marlowe.Runtime.Web
+import Marlowe.Runtime.Web.Client (uriOpts)
 import Marlowe.Runtime.Web.Types (HealthCheck(..), NetworkId(..), ServerURL(..))
+import Parsing as Parsing
 import Partial.Unsafe (unsafePartial)
 import React.Basic (createContext)
 import React.Basic.DOM.Client (createRoot, renderRoot)
+import URI (RelativeRef(..), URI(..)) as URI
+import URI.Extra.QueryPairs (QueryPairs(..)) as URI
+import URI.URIRef as URIRef
 import Web.DOM (Element)
 import Web.DOM.NonElementParentNode (getElementById)
 import Web.HTML (HTMLDocument, window)
 import Web.HTML.HTMLDocument (toNonElementParentNode)
+import Web.HTML.HTMLDocument as HTMLDocument
+import Web.HTML.History (DocumentTitle(..))
+import Web.HTML.History as History
+import Web.HTML.Location as Location
 import Web.HTML.Window (document)
+import Web.HTML.Window as Window
 
 type Config =
   { marloweWebServerUrl :: ServerURL
@@ -50,6 +65,40 @@ decodeConfig json = do
     , aboutMarkdown
     }
 
+-- We extract a possible contract json from the URL here:
+processInitialURL :: Effect (Maybe ContractJsonString)
+processInitialURL = do
+  location <- window >>= Window.location
+  href <- Location.href location
+  let
+    possibleUriRef = Parsing.runParser href (URIRef.parser uriOpts)
+    href' /\ possibleContract = fromMaybe (href /\ Nothing) do
+      uriRef <- hush $ possibleUriRef
+      let
+        extractContractJson possibleOrigQuery = do
+          URI.QueryPairs queryPairs <- possibleOrigQuery
+          contractJsonString <- join $ Foldable.lookup "contract" queryPairs
+          let
+            queryPairs' = Array.filter ((/=) "contract" <<< fst) queryPairs
+          pure (URI.QueryPairs queryPairs' /\ ContractJsonString contractJsonString)
+
+      uriRef' /\ c <- case uriRef of
+        Right (URIRef.RelativeRef relativePart query fragment) -> do
+          query' /\ contractJsonString <- extractContractJson query
+          pure (Right (URI.RelativeRef relativePart (Just query') fragment) /\ contractJsonString)
+        Left (URI.URI scheme hp query fragment) -> do
+          query' /\ contractJsonString <- extractContractJson query
+          pure (Left (URI.URI scheme hp (Just query') fragment) /\ contractJsonString)
+      pure (URIRef.print uriOpts uriRef' /\ Just c)
+  -- Location.setHref href' location
+  when (href' /= href) do
+    w <- window
+    history <- Window.history w
+    title <- Window.document w >>= HTMLDocument.title
+    History.replaceState Foreign.null (DocumentTitle title) (History.URL href') history
+
+  pure possibleContract
+
 main :: Json -> Effect Unit
 main configJson = do
   config <- Effect.liftEither $ decodeConfig configJson
@@ -64,6 +113,9 @@ main configJson = do
       else const (pure unit)
     runtime@(Marlowe.Runtime.Web.Runtime { serverURL }) = Marlowe.Runtime.Web.runtime config.marloweWebServerUrl
 
+  -- We do this URL processing here because the future URL routing will initialized here as well.
+  possibleInitialContract <- processInitialURL
+
   doc :: HTMLDocument <- document =<< window
   container :: Element <- maybe (throw "Could not find element with id 'app-root'") pure =<<
     (getElementById "app-root" $ toNonElementParentNode doc)
@@ -97,4 +149,4 @@ main configJson = do
             }
 
         app <- liftEffect $ runReaderT mkApp mkAppCtx
-        liftEffect $ renderRoot reactRoot $ msgHubComponent [ app unit ]
+        liftEffect $ renderRoot reactRoot $ msgHubComponent [ app { possibleInitialContract } ]