Use browser clipboard api in a safe manner (#26)

PLT-8060

src/Component/ConnectWallet.purs

@@ -108,7 +108,7 @@ mkConnectWallet = do
           nami <- liftEffect (Wallet.nami cardano) >>= traverse walletInfo
           yoroi <- liftEffect (Wallet.yoroi cardano) >>= traverse walletInfo
           typhon <- liftEffect (Wallet.typhon cardano) >>= traverse walletInfo
-          case ArrayAL.fromArray (Proxy :: Proxy 1) (Array.catMaybes [ lace, nami, gerowallet, yoroi, eternl, typhon ]) of
+          case ArrayAL.fromArray (Proxy :: Proxy 1) (Array.catMaybes [ eternl, gerowallet, lace, nami, typhon, yoroi ]) of
             Nothing -> liftEffect $ do
               setWallets NoWalletsAvailable
               onWalletConnect NoWallets

src/Component/ContractList.purs

@@ -30,6 +30,7 @@ import Contrib.React.Svg (loadingSpinnerLogo)
 import Contrib.ReactBootstrap.DropdownButton (dropdownButton)
 import Contrib.ReactBootstrap.DropdownItem (dropdownItem)
 import Contrib.ReactBootstrap.FormSpecBuilders.StatelessFormSpecBuilders (StatelessBootstrapFormSpec, textInput)
+import Contrib.Web.Clipboard as Contrib.Web.Clipboard
 import Control.Alt ((<|>))
 import Control.Alternative as Alternative
 import Control.Monad.Error.Class (throwError)
@@ -45,6 +46,7 @@ import Data.Either (Either, hush)
 import Data.Foldable (fold, for_, or)
 import Data.FormURLEncoded.Query (FieldId(..), Query)
 import Data.Function (on)
+import Data.Functor.Variant (case_)
 import Data.JSDate (fromDateTime) as JSDate
 import Data.List (intercalate)
 import Data.List as List
@@ -201,7 +203,7 @@ someContractTags (NotSyncedCreatedContract { tags }) = runnerTags tags
 mkContractList :: MkComponentM (Props -> JSX)
 mkContractList = do
   MessageHub msgHubProps <- asks _.msgHub
-
+  browserCapabilities <- asks _.browserCapabilities
   createContractComponent <- CreateContract.mkComponent
   applyInputsComponent <- ApplyInputs.mkComponent
   withdrawalsComponent <- Withdrawals.mkComponent
@@ -478,10 +480,6 @@ mkContractList = do
                       let
                         conractIdStr = txOutRefToString contractId
 
-                        copyToClipboard :: Effect Unit
-                        copyToClipboard = window >>= navigator >>= clipboard >>= \c -> do
-                          launchAff_ (Promise.toAffE $ Clipboard.writeText conractIdStr c)
-
                       tdCentered $ DOM.span { className: "d-flex" }
                         [ case possibleMarloweInfo of
                             Just (MarloweInfo { state, currentContract, initialContract, initialState }) -> do
@@ -496,18 +494,26 @@ mkContractList = do
                                       , initialContract: initialContract
                                       , transactionEndpoints
                                       }
-                                  { className: "cursor-pointer text-decoration-none text-reset text-decoration-underline-hover truncate-text w-16rem d-inline-block"
+                                  { className: "cursor-pointer text-decoration-none text-reset text-decoration-underline-hover d-inline-block" <> case browserCapabilities.clipboard of
+                                      Just _ -> " truncate-text w-16rem"
+                                      Nothing -> ""
                                   , onClick: handler_ onClick
                                   }
                                 [ text conractIdStr ]
                             Nothing -> DOM.span { className: "text-muted truncate-text w-16rem" } $ text conractIdStr
-                        , DOM.a
-                            { href: "#"
-                            , onClick: handler_ copyToClipboard
-                            , className: "cursor-pointer text-decoration-none text-decoration-underline-hover text-reset"
-                            }
-                            $ Icons.toJSX
-                            $ unsafeIcon "clipboard-plus ms-1 d-inline-block"
+                        , case browserCapabilities.clipboard of
+                            Just clipboard -> do
+                              let
+                                copyToClipboard :: Effect Unit
+                                copyToClipboard = launchAff_ (Promise.toAffE $ Clipboard.writeText conractIdStr clipboard)
+                              DOM.a
+                                { href: "#"
+                                , onClick: handler_ copyToClipboard
+                                , className: "cursor-pointer text-decoration-none text-decoration-underline-hover text-reset"
+                                }
+                                $ Icons.toJSX
+                                $ unsafeIcon "clipboard-plus ms-1 d-inline-block"
+                            Nothing -> mempty
                         ]
 
                   mkTable

src/Component/Types.purs

@@ -1,5 +1,6 @@
 module Component.Types
-  ( ContractJsonString(..)
+  ( BrowserCapabilities(..)
+  , ContractJsonString(..)
   , ConfigurationError(..)
   , MkContextBase(..)
   , MkComponentMBase(..)
@@ -30,6 +31,7 @@ import Marlowe.Runtime.Web.Types as Runtime
 import React.Basic (JSX, ReactContext)
 import Wallet as Wallet
 import WalletContext (WalletContext)
+import Web.Clipboard (Clipboard)
 
 newtype WalletInfo wallet = WalletInfo
   { name :: String
@@ -60,8 +62,13 @@ newtype MessageHub = MessageHub
   , ctx :: ReactContext (List Message)
   }
 
+type BrowserCapabilities =
+  { clipboard :: Maybe Clipboard
+  }
+
 type MkContextBase r =
-  { cardanoMultiplatformLib :: CardanoMultiplatformLib.Lib
+  { browserCapabilities :: BrowserCapabilities
+  , cardanoMultiplatformLib :: CardanoMultiplatformLib.Lib
   , walletInfoCtx :: ReactContext (Maybe (WalletInfo Wallet.Api /\ WalletContext))
   -- FIXME: use more advanced logger so we use levels and setup app verbosity.
   , logger :: String -> Effect Unit

src/Contrib/Web/Clipboard.purs

@@ -0,0 +1,14 @@
+module Contrib.Web.Clipboard where
+
+import Prelude
+import Effect (Effect)
+import Data.Undefined.NoProblem (Opt, opt)
+import Web.Clipboard as Clipboard
+import Web.Clipboard (Clipboard)
+import Web.HTML (Navigator)
+
+clipboard :: Navigator -> Effect (Opt Clipboard)
+clipboard n = do
+  c <- Clipboard.clipboard n
+  -- This makes it safe
+  pure $ opt c

src/Main.purs

@@ -12,6 +12,7 @@ import Contrib.Effect as Effect
 import Contrib.Fetch (fetchEither)
 import Contrib.JsonBigInt as JsonBigInt
 import Contrib.LZString (decompressFromURI)
+import Contrib.Web.Clipboard as Contrib.Web.Clipboard
 import Control.Monad.Reader (runReaderT)
 import Data.Argonaut (Json, decodeJson, (.:), (.:?))
 import Data.Array as Array
@@ -21,6 +22,7 @@ import Data.Foldable as Foldable
 import Data.Maybe (Maybe(..), fromJust, fromMaybe, maybe)
 import Data.Tuple (fst)
 import Data.Tuple.Nested ((/\))
+import Data.Undefined.NoProblem as NoProblem
 import Effect (Effect)
 import Effect.Aff (launchAff_)
 import Effect.Class (liftEffect)
@@ -143,85 +145,90 @@ mkSetPage origClasses appContainer = do
   { setPage, setPageClass }
 
 main :: Json -> Effect Unit
-main configJson = launchAff_ do
-  buildConfig <- liftEffect do
+main configJson = do
+  browserCapabilities <- do
+    clipboard <- window >>= Window.navigator >>= Contrib.Web.Clipboard.clipboard >>= NoProblem.toMaybe >>> pure
+    pure { clipboard }
+  buildConfig <- do
     JsonBigInt.patchers.patchStringify
     JsonBigInt.patchers.patchParse
-    liftEffect $ Effect.liftEither $ decodeBuildConfig configJson
-
-  let
-    throw' msg = liftEffect $ do
-      window >>= alert msg
-      throw msg
-
-  config <- do
-    fetchEither configURL {} [ 200, 404 ] identity >>= case _ of
-      Right res -> case res.status, buildConfig of
-        404, { marloweWebServerUrl: Just marloweWebServerUrl } ->
-          pure { marloweWebServerUrl, develMode: buildConfig.develMode }
-        404, _ -> do
-          throw' "Incomplete configuration - please create a config.json file in the root of the project - more info in the README"
-        200, _ -> do
-          possibleConfig <- do
-            json <- res.json <#> (unsafeCoerce :: Foreign -> Json)
-            pure $ decodeConfig json
-          case possibleConfig of
-            Left err -> do
-              throw' $ "Error parsing '/config.json': " <> show err
-            Right config -> pure config
-        _, _ -> do
-          throw' $ "Unexpected status code fetching '/config.json': " <> show res.status
-      Left err -> do
-        throw' $ "Error fetching '/config.json': " <> unsafeStringify err
-  let
-    logger :: String -> Effect Unit
-    logger =
-      if config.develMode then Console.log
-      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 <- liftEffect processInitialURL
-
-  doc :: HTMLDocument <- liftEffect $ document =<< window
-  appContainer :: Element <- liftEffect $ maybe (throw "Could not find element with id 'app-root'") pure =<<
-    (getElementById "app-root" $ toNonElementParentNode doc)
-
-  reactRoot <- liftEffect $ createRoot appContainer
-
-  networkId /\ possibleConfigurationError <- Marlowe.Runtime.Web.getHealthCheck serverURL >>= case _ of
-    Left err -> pure ((Testnet (NetworkMagic 1)) /\ Just (RuntimeNotResponding serverURL $ unsafeStringify err))
-    Right (HealthCheck { networkId }) -> pure (networkId /\ Nothing)
-
-  let
-    -- FIXME: Slotting numbers have to be provided by Marlowe Runtime
-    slotting = case networkId of
-      Mainnet -> Slotting { slotLength: BigInt.fromInt 1000, slotZeroTime: unsafePartial $ fromJust $ BigInt.fromString "1591566291000" }
-      Testnet (NetworkMagic 1) -> Slotting { slotLength: BigInt.fromInt 1000, slotZeroTime: unsafePartial $ fromJust $ BigInt.fromString "1655683200000" }
-      _ -> Slotting { slotLength: BigInt.fromInt 1000, slotZeroTime: unsafePartial $ fromJust $ BigInt.fromString "1666656000000" }
-
-  CardanoMultiplatformLib.importLib >>= case _ of
-    Nothing -> liftEffect $ logger "Cardano serialization lib loading failed"
-    Just cardanoMultiplatformLib -> do
-      walletInfoCtx <- liftEffect $ createContext Nothing
-      msgHubComponent /\ msgHub <- liftEffect $ mkMessageHub
-      let
-        mkAppCtx =
-          { cardanoMultiplatformLib
-          , develMode: config.develMode
-          , walletInfoCtx
-          , logger
-          , msgHub
-          , runtime
-          , slotting
-          , networkId
-          }
-
-      origClasses <- liftEffect $ fromMaybe "" <$> getAttribute "class" appContainer
-      let
-        { setPage, setPageClass } = mkSetPage origClasses appContainer
-
-      liftEffect $ setPageClass LoginPage
-
-      app <- liftEffect $ runReaderT mkApp mkAppCtx
-      liftEffect $ renderRoot reactRoot $ msgHubComponent [ app { possibleConfigurationError, possibleInitialContract, setPage } ]
+    Effect.liftEither $ decodeBuildConfig configJson
+
+  launchAff_ do
+    let
+      throw' msg = liftEffect $ do
+        window >>= alert msg
+        throw msg
+
+    config <- do
+      fetchEither configURL {} [ 200, 404 ] identity >>= case _ of
+        Right res -> case res.status, buildConfig of
+          404, { marloweWebServerUrl: Just marloweWebServerUrl } ->
+            pure { marloweWebServerUrl, develMode: buildConfig.develMode }
+          404, _ -> do
+            throw' "Incomplete configuration - please create a config.json file in the root of the project - more info in the README"
+          200, _ -> do
+            possibleConfig <- do
+              json <- res.json <#> (unsafeCoerce :: Foreign -> Json)
+              pure $ decodeConfig json
+            case possibleConfig of
+              Left err -> do
+                throw' $ "Error parsing '/config.json': " <> show err
+              Right config -> pure config
+          _, _ -> do
+            throw' $ "Unexpected status code fetching '/config.json': " <> show res.status
+        Left err -> do
+          throw' $ "Error fetching '/config.json': " <> unsafeStringify err
+    let
+      logger :: String -> Effect Unit
+      logger =
+        if config.develMode then Console.log
+        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 <- liftEffect processInitialURL
+
+    doc :: HTMLDocument <- liftEffect $ document =<< window
+    appContainer :: Element <- liftEffect $ maybe (throw "Could not find element with id 'app-root'") pure =<<
+      (getElementById "app-root" $ toNonElementParentNode doc)
+
+    reactRoot <- liftEffect $ createRoot appContainer
+
+    networkId /\ possibleConfigurationError <- Marlowe.Runtime.Web.getHealthCheck serverURL >>= case _ of
+      Left err -> pure ((Testnet (NetworkMagic 1)) /\ Just (RuntimeNotResponding serverURL $ unsafeStringify err))
+      Right (HealthCheck { networkId }) -> pure (networkId /\ Nothing)
+
+    let
+      -- FIXME: Slotting numbers have to be provided by Marlowe Runtime
+      slotting = case networkId of
+        Mainnet -> Slotting { slotLength: BigInt.fromInt 1000, slotZeroTime: unsafePartial $ fromJust $ BigInt.fromString "1591566291000" }
+        Testnet (NetworkMagic 1) -> Slotting { slotLength: BigInt.fromInt 1000, slotZeroTime: unsafePartial $ fromJust $ BigInt.fromString "1655683200000" }
+        _ -> Slotting { slotLength: BigInt.fromInt 1000, slotZeroTime: unsafePartial $ fromJust $ BigInt.fromString "1666656000000" }
+
+    CardanoMultiplatformLib.importLib >>= case _ of
+      Nothing -> liftEffect $ logger "Cardano serialization lib loading failed"
+      Just cardanoMultiplatformLib -> do
+        walletInfoCtx <- liftEffect $ createContext Nothing
+        msgHubComponent /\ msgHub <- liftEffect $ mkMessageHub
+        let
+          mkAppCtx =
+            { browserCapabilities
+            , cardanoMultiplatformLib
+            , develMode: config.develMode
+            , walletInfoCtx
+            , logger
+            , msgHub
+            , runtime
+            , slotting
+            , networkId
+            }
+
+        origClasses <- liftEffect $ fromMaybe "" <$> getAttribute "class" appContainer
+        let
+          { setPage, setPageClass } = mkSetPage origClasses appContainer
+
+        liftEffect $ setPageClass LoginPage
+
+        app <- liftEffect $ runReaderT mkApp mkAppCtx
+        liftEffect $ renderRoot reactRoot $ msgHubComponent [ app { possibleConfigurationError, possibleInitialContract, setPage } ]