From b73ddc680a40326f9d8b4052e3d83b5f9dbed08a Mon Sep 17 00:00:00 2001 From: paluh Date: Thu, 23 Nov 2023 12:00:08 +0100 Subject: [PATCH] Use browser clipboard api in a safe manner (#26) PLT-8060 --- src/Component/ConnectWallet.purs | 2 +- src/Component/ContractList.purs | 32 +++--- src/Component/Types.purs | 11 +- src/Contrib/Web/Clipboard.purs | 14 +++ src/Main.purs | 167 ++++++++++++++++--------------- 5 files changed, 130 insertions(+), 96 deletions(-) create mode 100644 src/Contrib/Web/Clipboard.purs diff --git a/src/Component/ConnectWallet.purs b/src/Component/ConnectWallet.purs index e272a1b5..e226b2ca 100644 --- a/src/Component/ConnectWallet.purs +++ b/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 diff --git a/src/Component/ContractList.purs b/src/Component/ContractList.purs index 4228baa8..38b40234 100644 --- a/src/Component/ContractList.purs +++ b/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 diff --git a/src/Component/Types.purs b/src/Component/Types.purs index e115cd39..ae198ffa 100644 --- a/src/Component/Types.purs +++ b/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 diff --git a/src/Contrib/Web/Clipboard.purs b/src/Contrib/Web/Clipboard.purs new file mode 100644 index 00000000..fac43f9e --- /dev/null +++ b/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 diff --git a/src/Main.purs b/src/Main.purs index 4bb466bd..98c98f74 100644 --- a/src/Main.purs +++ b/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 } ]