From 6b66b616b71cef4f5de6fc86ba8043b612d02298 Mon Sep 17 00:00:00 2001 From: jmininger Date: Sun, 7 Aug 2022 11:06:23 -0400 Subject: [PATCH 1/7] add createKSPrincipal and validateKSPrincipal --- frontend/src/Frontend/UI/Transfer.hs | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/frontend/src/Frontend/UI/Transfer.hs b/frontend/src/Frontend/UI/Transfer.hs index bf754717..a18a5b86 100644 --- a/frontend/src/Frontend/UI/Transfer.hs +++ b/frontend/src/Frontend/UI/Transfer.hs @@ -67,6 +67,8 @@ import qualified Codec.QRCode.JuicyPixels as QR import qualified Data.YAML.Aeson as Y import Pact.Types.SigData +import Pact.Types.Term (KeySet (..)) +import Pact.Types.Util (asString) import Kadena.SigningTypes (AccountName(..)) import Pact.Parse import qualified Pact.Server.ApiClient as Api @@ -183,6 +185,7 @@ toFormWidget model cfg = mdo divClass "labeled-input__input account-chain-input" $ uiChainAccount model $ mkPfwc (fst <$> cfg) & initialAttributes %~ (<> "placeholder" =: "Account Name or Paste Tx Builder") & setValue %~ modSetValue (Just (Just . mkChainAccount <$> pastedBuilder)) + -- & setValue .~ modSetValue (Just (Just . mkChainAccount <$> pastedBuilder)) let keysetStartsOpen = case snd (_initialValue cfg) of Nothing -> False @@ -195,8 +198,27 @@ toFormWidget model cfg = mdo keysetFormWidget $ (snd <$> cfg) & setValue %~ modSetValue (Just (fmap userFromPactKeyset . _txBuilder_keyset <$> pastedBuilder)) + -- let + -- dKS::_ = attach (current $ value tca) (updated $ fmapMaybe id k) + -- x = + -- -- Dynamic t (Maybe UserKeyset) + -- ffor (fmapMaybe id k) $ \mUKS -> + -- _ return (tca,k) +createKSPrincipal :: KeySet -> Text +createKSPrincipal (KeySet ks pf) = + case (toList ks,asString pf) of + ([k],"keys-all") -> "k:" <> asString k + (l,fun) -> do + let a = mkHash $ map Pact._pubKey l + in "w:" <> asString a <> ":" <> fun + where + mkHash = pactHash . mconcat + +validateKSPrincipal :: KeySet -> Text -> Bool +validateKSPrincipal ks name = createKSPrincipal ks == name + data TransferInfo = TransferInfo { _ti_fromAccount :: ChainAccount , _ti_fungible :: ModuleName From 447646a9e09b65b6efb87834e54ba6d0e2003975 Mon Sep 17 00:00:00 2001 From: jmininger Date: Mon, 8 Aug 2022 08:04:13 -0400 Subject: [PATCH 2/7] gtransfer: add principal account autofill --- frontend/src/Frontend/UI/Transfer.hs | 40 ++++++++++++++++++---------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/frontend/src/Frontend/UI/Transfer.hs b/frontend/src/Frontend/UI/Transfer.hs index a18a5b86..ff83ffcc 100644 --- a/frontend/src/Frontend/UI/Transfer.hs +++ b/frontend/src/Frontend/UI/Transfer.hs @@ -169,23 +169,26 @@ uiChainAccount model cfg = do (maybe (ChainId "0") _ca_chain <$> cfg) return (runMaybeT $ ChainAccount <$> lift cd <*> MaybeT a, onPaste) +modSetValue :: Reflex t => Maybe (Event t a) -> Maybe (Event t a) -> Maybe (Event t a) +modSetValue (Just e1) (Just e2) = Just $ leftmost [e1, e2] +modSetValue Nothing a = a +modSetValue a Nothing = a + toFormWidget :: (MonadWidget t m, HasNetwork model t) => model + -> Event t () -> FormWidgetConfig t (Maybe ChainAccount, Maybe UserKeyset) -> m (FormWidget t (Maybe ChainAccount), Dynamic t (Maybe UserKeyset)) -toFormWidget model cfg = mdo +toFormWidget model eClear cfg = mdo let pastedBuilder = fmapMaybe ((decode' . LB.fromStrict . T.encodeUtf8) =<<) $ onPaste mkChainAccount b = ChainAccount (_txBuilder_chainId b) (_txBuilder_accountName b) - modSetValue (Just e1) (Just e2) = Just $ leftmost [e1, e2] - modSetValue Nothing a = a - modSetValue a Nothing = a (tca,onPaste) <- elClass "div" ("segment segment_type_tertiary labeled-input-inline") $ do divClass ("label labeled-input__label-inline") $ text "Account" divClass "labeled-input__input account-chain-input" $ uiChainAccount model $ mkPfwc (fst <$> cfg) & initialAttributes %~ (<> "placeholder" =: "Account Name or Paste Tx Builder") & setValue %~ modSetValue (Just (Just . mkChainAccount <$> pastedBuilder)) - -- & setValue .~ modSetValue (Just (Just . mkChainAccount <$> pastedBuilder)) + & setValue %~ modSetValue (Just $ leftmost [Nothing <$ eClear, Just <$> eNewPrincipal]) let keysetStartsOpen = case snd (_initialValue cfg) of Nothing -> False @@ -197,14 +200,23 @@ toFormWidget model cfg = mdo (clk,(_,k)) <- controlledAccordionItem keysetOpen mempty (accordionHeaderBtn "Owner Keyset") $ do keysetFormWidget $ (snd <$> cfg) & setValue %~ modSetValue (Just (fmap userFromPactKeyset . _txBuilder_keyset <$> pastedBuilder)) + & setValue %~ modSetValue (Just $ Nothing <$ eClear) + + let + eKSAndChainAddr = attach (current $ value tca) $ updated k + eNewPrincipal = fforMaybe eKSAndChainAddr $ \(mCa, mKS) -> + case (mCa, mKS) of + (Nothing, Just ks) -> Just $ ChainAccount (ChainId "0") $ toPrincipalAccName ks + (Just (ChainAccount cid (AccountName an)), Just ks) -> + if isPrincipalAccName an + then Just $ ChainAccount cid $ toPrincipalAccName ks + else Nothing + otherwise -> Nothing - -- let - -- dKS::_ = attach (current $ value tca) (updated $ fmapMaybe id k) - -- x = - -- -- Dynamic t (Maybe UserKeyset) - -- ffor (fmapMaybe id k) $ \mUKS -> - -- _ return (tca,k) + where + isPrincipalAccName = (==) ':' . flip T.index 1 + toPrincipalAccName = AccountName . createKSPrincipal . userToPactKeyset createKSPrincipal :: KeySet -> Text createKSPrincipal (KeySet ks pf) = @@ -278,8 +290,8 @@ uiGenericTransfer model cfg = do -- Destination toAccountWidget eClear = divClass "transfer__right-pane" $ do el "h4" $ text "To" - toFormWidget model $ mkCfg (Nothing, Nothing) - & setValue .~ (Just $ (Nothing, Nothing) <$ eClear) + toFormWidget model eClear $ mkCfg (Nothing, Nothing) + -- & setValue .~ (Just $ (Nothing, Nothing) <$ eClear) -- Submit submitOrClearWidget transferInfo = divClass "transfer-fields submit" $ do @@ -1551,7 +1563,7 @@ transferMetadata model netInfo fks tks ti ty = do then Just 1200 else if fromChain == toChain then Just 600 - else Just 450 -- Cross-chains need to be under 450 in order to use gas-station + else Just 465 -- Cross-chains need to be under 500 in order to use gas-station (conf, ttl, lim, price) <- uiMetaData model Nothing defaultLimit elAttr "div" ("style" =: "margin-top: 10px") $ do now <- fmap round $ liftIO $ getPOSIXTime From faef318da9f6473e042950a200b43e0ec5432271 Mon Sep 17 00:00:00 2001 From: jmininger Date: Sun, 4 Sep 2022 13:56:10 -0400 Subject: [PATCH 3/7] show cont-req-key --- .../src/Frontend/UI/DeploymentSettings.hs | 6 ++++++ frontend/src/Frontend/UI/Dialogs/Send.hs | 8 ++++---- frontend/src/Frontend/UI/Transfer.hs | 19 ++++++++++--------- 3 files changed, 20 insertions(+), 13 deletions(-) diff --git a/frontend/src/Frontend/UI/DeploymentSettings.hs b/frontend/src/Frontend/UI/DeploymentSettings.hs index 067ce543..e7219c60 100644 --- a/frontend/src/Frontend/UI/DeploymentSettings.hs +++ b/frontend/src/Frontend/UI/DeploymentSettings.hs @@ -53,6 +53,7 @@ module Frontend.UI.DeploymentSettings , transactionInputSection , transactionHashSection + , contHashSection , transactionDisplayNetwork -- * Useful re-exports , Identity (runIdentity) @@ -585,6 +586,11 @@ advancedAccordion m active = do dialogSectionHeading mempty "Data" uiJsonDataSetFocus (\_ _ -> pure ()) (\_ _ -> pure ()) (m ^. wallet) (m ^. jsonData) +contHashSection :: MonadWidget t m => Pact.RequestKey -> m () +contHashSection hsh = void $ do + mkLabeledInput True "Request Key (p2)" (\c -> uiInputElement $ c & initialAttributes %~ Map.insert "disabled" "") $ def + & inputElementConfig_initialValue .~ Pact.requestKeyToB16Text hsh + transactionHashSection :: MonadWidget t m => Pact.Command Text -> m () transactionHashSection cmd = void $ do mkLabeledInput True "Request Key" (\c -> uiInputElement $ c & initialAttributes %~ Map.insert "disabled" "") $ def diff --git a/frontend/src/Frontend/UI/Dialogs/Send.hs b/frontend/src/Frontend/UI/Dialogs/Send.hs index 729c0fe8..67d42e8d 100644 --- a/frontend/src/Frontend/UI/Dialogs/Send.hs +++ b/frontend/src/Frontend/UI/Dialogs/Send.hs @@ -518,7 +518,7 @@ runUnfinishedCrossChainTransfer -> Event t Pact.RequestKey -- ^ The request key to follow up on -> PublicMeta - -> m (Event t (), Event t Text, Event t ()) + -> m (Event t (), Event t Text, Event t (), Event t Pact.RequestKey) runUnfinishedCrossChainTransfer logL netInfo keys fromChain toChain mtoGasPayer requestKey publicMeta = mdo let nodeInfos = _sharedNetInfo_nodes netInfo networkName = _sharedNetInfo_network netInfo @@ -536,11 +536,11 @@ runUnfinishedCrossChainTransfer logL netInfo keys fromChain toChain mtoGasPayer , Status_Done <$ contOk ] - es@(resultOk, resultErr, retry) <- case mtoGasPayer of + es@(resultOk, resultErr, retry, eContReqKey) <- case mtoGasPayer of Nothing -> do dialogSectionHeading mempty "Notice: Cannot finish cross-chain transfer" divClass "group" $ text "No gas payer specified on destination chain" - return (() <$ contResponse, never, never) + return (() <$ contResponse, never, never, never) Just toGasPayer -> do -- Get the proof spvResponse <- getSPVProof logL nodeInfos fromChain toChain contOk @@ -592,6 +592,7 @@ runUnfinishedCrossChainTransfer logL netInfo keys fromChain toChain mtoGasPayer pure ( resultOk , leftmost [contError, spvError, continueError, resultError] , retry + , snd <$> continueOk ) pure es @@ -877,7 +878,6 @@ continueCrossChainTransfer logL networkName envs publicMeta keys toChain gasPaye performEventAsync $ ffor spvOk $ \(pe, proof) cb -> do let sender = unAccountName $ fst gasPayer - pm = publicMeta { _pmChainId = toChain , _pmSender = sender diff --git a/frontend/src/Frontend/UI/Transfer.hs b/frontend/src/Frontend/UI/Transfer.hs index 42245426..1683183d 100644 --- a/frontend/src/Frontend/UI/Transfer.hs +++ b/frontend/src/Frontend/UI/Transfer.hs @@ -461,7 +461,7 @@ lookupAndTransfer model netInfo ti ty onCloseExternal = do let tks = fromMaybe mempty t modHashMap <- sample $ current $ model ^. wallet_moduleData (conf, closes) <- fmap splitDynPure $ workflow $ - -- checkSendingAccountExists model netInfo ti ty fks tks + -- checkSendingAccountExists model netInfo ti ty fks tks <|> checkContractHashOnBothChains model netInfo ti ty fks tks modHashMap mConf <- flatten =<< tagOnPostBuild conf let close = switch $ current closes @@ -1071,14 +1071,15 @@ crossChainTransferAndStatus model netInfo ti cmd mdestGP destSigners toMeta = Wo let listenDone = ffilter (==Status_Done) $ updated $ _transactionSubmitFeedback_listenStatus fbk -- Not sure whether this should be when the listen is done or when the send is done rk = RequestKey (toUntypedHash $ _cmdHash cmd) <$ listenDone - (resultOk0, errMsg0, retry0) <- divClass "group" $ do - elClass "ol" "transaction_status" $ do - let item ds = elDynAttr "li" (ffor ds $ \s -> "class" =: statusText s) - item (_transactionSubmitFeedback_sendStatus fbk) $ - el "p" $ text $ "Cross chain transfer initiated on chain " <> _chainId fromChain - - keys <- sample $ current $ model ^. wallet_keys - runUnfinishedCrossChainTransfer logL netInfo keys fromChain toChain mdestGP rk toChainMeta + rec widgetHold_ blank $ ffor eContReqKey $ \contCmd -> contHashSection contCmd + (resultOk0, errMsg0, retry0, eContReqKey) <- divClass "group" $ do + elClass "ol" "transaction_status" $ do + let item ds = elDynAttr "li" (ffor ds $ \s -> "class" =: statusText s) + item (_transactionSubmitFeedback_sendStatus fbk) $ + el "p" $ text $ "Cross chain transfer initiated on chain " <> _chainId fromChain + + keys <- sample $ current $ model ^. wallet_keys + runUnfinishedCrossChainTransfer logL netInfo keys fromChain toChain mdestGP rk toChainMeta let isError = \case Just (Left _) -> True From 236bf92312cc477794781312558c581f85804a28 Mon Sep 17 00:00:00 2001 From: jmininger Date: Sun, 4 Sep 2022 14:49:22 -0400 Subject: [PATCH 4/7] disallow transfer of 0 --- frontend/src/Frontend/UI/Form/Common.hs | 11 +++++++++-- frontend/src/Frontend/UI/Transfer.hs | 1 + 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/frontend/src/Frontend/UI/Form/Common.hs b/frontend/src/Frontend/UI/Form/Common.hs index c688068c..fabcc0c6 100644 --- a/frontend/src/Frontend/UI/Form/Common.hs +++ b/frontend/src/Frontend/UI/Form/Common.hs @@ -92,10 +92,17 @@ amountFormWidget => PrimFormWidgetConfig t (Either String Decimal) -> m (FormWidget t (Either String Decimal)) amountFormWidget cfg = do - parsingFormWidget parseAmount (either (const "") tshow) cfg + parsingFormWidget parseTransferAmount (either (const "") tshow) cfg + +-- parseAmount that cant be 0 +parseTransferAmount :: Text -> Either String Decimal +parseTransferAmount t = parseAmount t >>= \a -> + case a == 0 of + True -> Left "Cant transfer amount of 0" + False -> pure a parseAmount :: Text -> Either String Decimal -parseAmount t = +parseAmount t = let tNoLeadingDecimal = if "." `T.isPrefixOf` t then "0" <> t else t in case D.normalizeDecimal <$> readMaybe (T.unpack tNoLeadingDecimal) of Nothing -> Left "Not a valid number" diff --git a/frontend/src/Frontend/UI/Transfer.hs b/frontend/src/Frontend/UI/Transfer.hs index 1683183d..f7ce6c15 100644 --- a/frontend/src/Frontend/UI/Transfer.hs +++ b/frontend/src/Frontend/UI/Transfer.hs @@ -668,6 +668,7 @@ checkContractHashOnBothChains -> ModuleData -> Workflow t m (mConf, Event t ()) checkContractHashOnBothChains model netInfo ti ty fks tks modHashMap = do + -- TODO: Need to check for blessed hashes too; let toChain = _ca_chain $ _ti_toAccount ti fromChain = _ca_chain $ _ti_fromAccount ti --TODO: Just pass this val in as arg instead of passing around the whole map From 38a87019ce9170cb5089341098ad0003360065fb Mon Sep 17 00:00:00 2001 From: jmininger Date: Thu, 8 Sep 2022 15:57:58 -0400 Subject: [PATCH 5/7] multisig: if keyset cannot be derived for w: check rest of wallet first before failing --- common/src/Common/Wallet.hs | 4 + frontend/src/Frontend/UI/Transfer.hs | 272 ++++++++++++++++----------- 2 files changed, 170 insertions(+), 106 deletions(-) diff --git a/common/src/Common/Wallet.hs b/common/src/Common/Wallet.hs index e0d67640..9316f2b7 100644 --- a/common/src/Common/Wallet.hs +++ b/common/src/Common/Wallet.hs @@ -203,6 +203,10 @@ parsePubKeyOrKAccount :: AccountName -> (Bool, Either Text PublicKey) parsePubKeyOrKAccount (AccountName accName) = second parsePublicKey $ maybe (False, accName) (\k -> (True, k)) $ T.stripPrefix "k:" accName +-- parsePrincipal :: AccountName -> Maybe Text +-- parsePrincipal (AccountName accName) = +-- T.stripPrefix "k:" accName <|> T.stripPrefix "w:" accName + throwDecodingErr :: MonadError Text m => Maybe v diff --git a/frontend/src/Frontend/UI/Transfer.hs b/frontend/src/Frontend/UI/Transfer.hs index f7ce6c15..03810b64 100644 --- a/frontend/src/Frontend/UI/Transfer.hs +++ b/frontend/src/Frontend/UI/Transfer.hs @@ -35,7 +35,6 @@ Design Requirements: {-# LANGUAGE TypeFamilies #-} module Frontend.UI.Transfer where - import Control.Applicative import Control.Error hiding (bool, note) import Control.Lens hiding ((.=)) @@ -456,13 +455,19 @@ lookupAndTransfer model netInfo ti ty onCloseExternal = do [ (\ks (_,b) -> (Just ks, b)) <$> efks , (\ks (a,_) -> (a, Just ks)) <$> etks ] - let eWrapper (Just f, Just t) = do + + mAccs <- sample $ current $ Map.lookup <$> + (model ^. network_selectedNetwork) <*> + (fmap unAccountData $ model ^. wallet_accounts) + let toSimilarKeysets = constructKSFromOthers toAccount mAccs + eWrapper (Just f, Just t) = do let fks = fromMaybe mempty f let tks = fromMaybe mempty t modHashMap <- sample $ current $ model ^. wallet_moduleData + (conf, closes) <- fmap splitDynPure $ workflow $ -- checkSendingAccountExists model netInfo ti ty fks tks <|> - checkContractHashOnBothChains model netInfo ti ty fks tks modHashMap + checkContractHashOnBothChains model netInfo ti ty fks tks modHashMap toSimilarKeysets mConf <- flatten =<< tagOnPostBuild conf let close = switch $ current closes pure (mConf, close) @@ -476,6 +481,25 @@ lookupAndTransfer model netInfo ti ty onCloseExternal = do setify :: Ord a => [a] -> [a] setify = Set.toList . Set.fromList + constructKSFromOthers toAccount mAccs = do + let + accExists a = case a of + AccountStatus_Exists a -> Just a + otherwise -> Nothing + guardToMKeyset ag = case ag of + AccountGuard_KeySetLike ks -> Just $ toPactKeyset ks + otherwise -> Nothing + mMultiKS = do + accMap <- mAccs + accDets <- Map.lookup toAccount accMap + dets <- headMay $ catMaybes $ fmap (accExists . _account_status) $ Map.elems $ _accountInfo_chains accDets + guardToMKeyset $ _accountDetails_guard dets + in case mMultiKS of + Just ks + | (validateKSPrincipal ks $ unAccountName toAccount) -> Just $ userFromPactKeyset ks + otherwise -> Nothing + + msgModal :: (DomBuilder t m, PostBuild t m, Monoid mConf) => Text -> m a -> m (mConf, Event t ()) msgModal headerMsg body = do close <- modalHeader $ text headerMsg @@ -576,12 +600,13 @@ checkSendingAccountExists -> TransferType -> Map AccountName (AccountStatus AccountDetails) -> Map AccountName (AccountStatus AccountDetails) + -> Maybe UserKeyset -> Workflow t m (mConf, Event t ()) -checkSendingAccountExists model netInfo ti ty fks tks = do +checkSendingAccountExists model netInfo ti ty fks tks toLKS = do let fromAccount = _ca_account $ _ti_fromAccount ti case Map.lookup fromAccount fks of - Just (AccountStatus_Exists ad) -> - checkReceivingAccount model netInfo ti ty fks tks (fromAccount, ad) + Just (AccountStatus_Exists ad) -> do + checkReceivingAccount model netInfo ti ty fks tks (fromAccount, ad) toLKS _ -> Workflow $ do cancel <- fatalTransferError $ text $ "Sending account " <> unAccountName fromAccount <> " does not exist." @@ -606,8 +631,9 @@ checkModuleFungibleXChain -> TransferType -> Map AccountName (AccountStatus AccountDetails) -> Map AccountName (AccountStatus AccountDetails) + -> Maybe UserKeyset -> Workflow t m (mConf, Event t ()) -checkModuleFungibleXChain model netInfo ti ty fks tks = +checkModuleFungibleXChain model netInfo ti ty fks tks toLKS = let toChain = _ca_chain $ _ti_toAccount ti fromChain = _ca_chain $ _ti_fromAccount ti in case moduleName == "coin" of @@ -635,7 +661,7 @@ checkModuleFungibleXChain model netInfo ti ty fks tks = networkName = _sharedNetInfo_network netInfo moduleName = renderCompactText $ _ti_fungible ti interfaceCheckPact = "(contains 'fungible-xchain-v1 (at 'interfaces (describe-module \"" <> moduleName <> "\")))" - nextW = checkSendingAccountExists model netInfo ti ty fks tks + nextW = checkSendingAccountExists model netInfo ti ty fks tks toLKS defMeta = (_sharedNetInfo_meta netInfo) { _pmChainId = toChain , _pmSender = "sender00" @@ -666,8 +692,9 @@ checkContractHashOnBothChains -> Map AccountName (AccountStatus AccountDetails) -> Map AccountName (AccountStatus AccountDetails) -> ModuleData + -> Maybe UserKeyset -> Workflow t m (mConf, Event t ()) -checkContractHashOnBothChains model netInfo ti ty fks tks modHashMap = do +checkContractHashOnBothChains model netInfo ti ty fks tks modHashMap toLKS = do -- TODO: Need to check for blessed hashes too; let toChain = _ca_chain $ _ti_toAccount ti fromChain = _ca_chain $ _ti_fromAccount ti @@ -676,7 +703,7 @@ checkContractHashOnBothChains model netInfo ti ty fks tks modHashMap = do --doesn't even exist), and the outer Maybe from the ModuleData map, (where Nothing implies --that our onchain lookup has not returned yet) hashPair = (,) <$> (join $ Map.lookup fromChain modHashMap) <*> (join $ Map.lookup toChain modHashMap) - nextW = checkModuleFungibleXChain model netInfo ti ty fks tks + nextW = checkModuleFungibleXChain model netInfo ti ty fks tks toLKS case hashPair of -- This case implies likely occurs during throttling, so we will continue and allow it -- to fail on-chain if there is actually an issue @@ -715,73 +742,94 @@ checkReceivingAccount -> Map AccountName (AccountStatus AccountDetails) -> Map AccountName (AccountStatus AccountDetails) -> (AccountName, AccountDetails) + -> Maybe UserKeyset -> Workflow t m (mConf, Event t ()) -checkReceivingAccount model netInfo ti ty fks tks fromPair = do - let toAccount = _ca_account $ _ti_toAccount ti - case (Map.lookup toAccount tks, _ti_toKeyset ti) of - -- TODO Might need more checks for cross-chain error cases - (Just (AccountStatus_Exists (AccountDetails _ g)), Just userKeyset) -> do - -- Use transfer-create, but check first to see whether it will fail - let AccountGuard_KeySetLike (KeySetHeritage ks p _ref) = g - let onChainKeyset = UserKeyset ks (parseKeysetPred p) - if onChainKeyset /= userKeyset - then Workflow $ do - cancel <- fatalTransferError $ do - el "div" $ text "Your keyset does not match the on-chain keyset. Your transfer would fail." - el "hr" blank - el "div" $ do - mkLabeledView False "Keyset You Entered" $ divClass "group" $ - keysetWidget userKeyset - mkLabeledView False "On-chain Keyset" $ divClass "group" $ - keysetWidget onChainKeyset - return ((mempty, cancel), never) - else - transferDialog model netInfo ti ty fks tks fromPair - (Just (AccountStatus_Exists (AccountDetails _ g)), Nothing) -> do - let - transferDialogWithWarn model netInfo ti ty fks tks fromPair = Workflow $ do - close <- modalHeader $ text "Account Keyset" - _ <- elClass "div" "modal__main" $ do - el "h3" $ text "WARNING" - el "div" $ text $ "The on-chain keyset of the receiving account does not match the account name. This may be an indicator of foul-play; you should confirm that the receiving keyset is the expected keyset before continuing" - el "hr" blank - el "div" $ text $ "If you are doing a cross-chain transfer to yourself, and see this message, you may want to reconsider, as it is possible that you don't have control over the account on the destination chain" - el "hr" blank - el "div" $ do - dialogSectionHeading mempty "Destination Account Name:" - mkLabeledInput False "Account Name" uiInputElement $ def - & initialAttributes .~ "disabled" =: "disabled" - & inputElementConfig_initialValue .~ (unAccountName toAccount) - dialogSectionHeading mempty "Destination Account Guard:" - uiDisplayKeyset g - modalFooter $ do - cancel <- cancelButton def "No, take me back" - let cfg = def & uiButtonCfg_class <>~ "button_type_confirm" - next <- uiButtonDyn cfg $ text "Yes, proceed to transfer" - return ((mempty, close <> cancel), - (transferDialog model netInfo ti ty fks tks fromPair) <$ next) - - transferDialogWithKeysetCheck = case accountNameMatchesKeyset toAccount g of - True -> transferDialog - False -> transferDialogWithWarn - if (_ca_chain $ _ti_fromAccount ti) /= (_ca_chain $ _ti_toAccount ti) - then do - case g of - AccountGuard_KeySetLike (KeySetHeritage ks p _ref) -> - let ti2 = ti { _ti_toKeyset = Just $ UserKeyset ks (parseKeysetPred p) } - in transferDialogWithKeysetCheck model netInfo ti2 ty fks tks fromPair - AccountGuard_Other _ -> transferDialogWithKeysetCheck model netInfo ti ty fks tks fromPair - else - -- Use transfer, probably show the guard at some point - -- TODO check well-formedness of all keys in the keyset - transferDialogWithKeysetCheck model netInfo ti ty fks tks fromPair - (_, Just userKeyset) -> do - -- Use transfer-create - transferDialog model netInfo ti ty fks tks fromPair - (_, Nothing) -> do - -- If the account name looks like a public key, ask about making a keyset - -- Otherwise throw an error - handleMissingKeyset model netInfo ti ty fks tks fromPair +checkReceivingAccount model netInfo ti ty fks tks fromPair toLKS = do + let toAccount = _ca_account $ _ti_toAccount ti + case (Map.lookup toAccount tks, _ti_toKeyset ti) of + -- TODO Might need more checks for cross-chain error cases + (Just (AccountStatus_Exists (AccountDetails _ g)), Just userKeyset) -> do + -- Use transfer-create, but check first to see whether it will fail + let AccountGuard_KeySetLike (KeySetHeritage ks p _ref) = g + let onChainKeyset = UserKeyset ks (parseKeysetPred p) + if onChainKeyset /= userKeyset + then Workflow $ do + cancel <- fatalTransferError $ do + el "div" $ text "Your keyset does not match the on-chain keyset. Your transfer would fail." + el "hr" blank + el "div" $ do + mkLabeledView False "Keyset You Entered" $ divClass "group" $ + keysetWidget userKeyset + mkLabeledView False "On-chain Keyset" $ divClass "group" $ + keysetWidget onChainKeyset + return ((mempty, cancel), never) + else + transferDialog model netInfo ti ty fks tks fromPair + (Just (AccountStatus_Exists (AccountDetails _ g)), Nothing) -> do + let + transferDialogWithWarn model netInfo ti ty fks tks fromPair = Workflow $ do + close <- modalHeader $ text "Account Keyset" + _ <- elClass "div" "modal__main" $ do + el "h3" $ text "WARNING" + el "div" $ text $ "The on-chain keyset of the receiving account does not match the account name. This may be an indicator of foul-play; you should confirm that the receiving keyset is the expected keyset before continuing" + el "hr" blank + el "div" $ text $ "If you are doing a cross-chain transfer to yourself, and see this message, you may want to reconsider, as it is possible that you don't have control over the account on the destination chain" + el "hr" blank + el "div" $ do + dialogSectionHeading mempty "Destination Account Name:" + mkLabeledInput False "Account Name" uiInputElement $ def + & initialAttributes .~ "disabled" =: "disabled" + & inputElementConfig_initialValue .~ (unAccountName toAccount) + dialogSectionHeading mempty "Destination Account Guard:" + uiDisplayKeyset g + modalFooter $ do + cancel <- cancelButton def "No, take me back" + let cfg = def & uiButtonCfg_class <>~ "button_type_confirm" + next <- uiButtonDyn cfg $ text "Yes, proceed to transfer" + return ((mempty, close <> cancel), + (transferDialog model netInfo ti ty fks tks fromPair) <$ next) + + transferDialogWithKeysetCheck = case accountNameMatchesKeyset toAccount g of + True -> transferDialog + False -> transferDialogWithWarn + if (_ca_chain $ _ti_fromAccount ti) /= (_ca_chain $ _ti_toAccount ti) + then do + case g of + AccountGuard_KeySetLike (KeySetHeritage ks p _ref) -> + let ti2 = ti { _ti_toKeyset = Just $ UserKeyset ks (parseKeysetPred p) } + in transferDialogWithKeysetCheck model netInfo ti2 ty fks tks fromPair + AccountGuard_Other _ -> transferDialogWithKeysetCheck model netInfo ti ty fks tks fromPair + else + -- Use transfer, probably show the guard at some point + -- TODO check well-formedness of all keys in the keyset + transferDialogWithKeysetCheck model netInfo ti ty fks tks fromPair + (_, Just userKeyset) -> do + -- Use transfer-create + transferDialog model netInfo ti ty fks tks fromPair + (_, Nothing) -> do + -- Account name given but with no keyset. Let's see if we can deduce some info + -- otherwise throw an error + handleMissingKeyset model netInfo ti ty fks tks fromPair toLKS + + +data AccountType = + SingleKey PublicKey --key + | MultiKey Text -- hash + | LegacyKey PublicKey + | OtherPrincipal Text + | Vanity Text + deriving (Show, Eq) + + +parseAccountName :: AccountName -> Either Text AccountType +parseAccountName (AccountName accName) = + case T.unpack accName of + 'k':':':key -> fmap SingleKey $ parsePublicKey $ T.pack key + 'w':':':hash -> Right $ MultiKey $ T.pack hash + _:':':_ -> Right $ OtherPrincipal accName + otherwise -> Right $ case parsePublicKey accName of + Right k -> LegacyKey k + Left _ -> Vanity accName handleMissingKeyset :: ( MonadWidget t m, Monoid mConf @@ -800,38 +848,50 @@ handleMissingKeyset -> Map AccountName (AccountStatus AccountDetails) -> Map AccountName (AccountStatus AccountDetails) -> (AccountName, AccountDetails) + -> Maybe UserKeyset -> Workflow t m (mConf, Event t ()) -handleMissingKeyset model netInfo ti ty fks tks fromPair = do - let - toAccount = _ca_account $ _ti_toAccount ti - toAccountText = unAccountName $ _ca_account $ _ti_toAccount ti - case parsePubKeyOrKAccount toAccount of - -- Vanity account name - (_, Left _) -> Workflow $ do - cancel <- fatalTransferError $ - el "div" $ text $ "Receiving account " <> toAccountText <> " does not exist. You must specify a keyset to create this account." - return ((mempty, cancel), never) - -- AccName "k:" --> Don't even ask approval to use it - (True, Right pk) -> do +handleMissingKeyset model netInfo ti ty fks tks fromPair toLKS = do + case parseAccountName toAccount of + Right (SingleKey pk) -> do + let ti2 = ti { _ti_toKeyset = Just $ UserKeyset (Set.singleton pk) KeysAll } + transferDialog model netInfo ti2 ty fks tks fromPair + Right (MultiKey _) -> multisigWF + Right (LegacyKey pk) -> legacyKeysetWF pk + Right (OtherPrincipal accName) -> vanityWF + Right (Vanity accName) -> vanityWF + -- Edgecase: k-account but not a valid public key + Left _ -> vanityWF + where + toAccount = _ca_account $ _ti_toAccount ti + toAccountText = unAccountName $ _ca_account $ _ti_toAccount ti + vanityWF = Workflow $ do + cancel <- fatalTransferError $ + el "div" $ text $ "Receiving account " <> toAccountText <> " does not exist. You must specify a keyset to create this account." + return ((mempty, cancel), never) + + legacyKeysetWF pk = Workflow $ do + close <- modalHeader $ text "Account Keyset" + _ <- elClass "div" "modal__main" $ do + el "div" $ text $ "The receiving account name looks like a public key and you did not specify a keyset. Would you like to use it as the keyset to send to?" + el "hr" blank + el "div" $ + mkLabeledInput False "Public Key" uiInputElement $ def + & initialAttributes .~ "disabled" =: "disabled" + & inputElementConfig_initialValue .~ toAccountText + modalFooter $ do + cancel <- cancelButton def "No, take me back" + let cfg = def & uiButtonCfg_class <>~ "button_type_confirm" + next <- uiButtonDyn cfg $ text "Yes, proceed to transfer" let ti2 = ti { _ti_toKeyset = Just $ UserKeyset (Set.singleton pk) KeysAll } - transferDialog model netInfo ti2 ty fks tks fromPair - -- AccName: "" --> Ask for approval - (False, Right pk) -> Workflow $ do - close <- modalHeader $ text "Account Keyset" - _ <- elClass "div" "modal__main" $ do - el "div" $ text $ "The receiving account name looks like a public key and you did not specify a keyset. Would you like to use it as the keyset to send to?" - el "hr" blank - el "div" $ - mkLabeledInput False "Public Key" uiInputElement $ def - & initialAttributes .~ "disabled" =: "disabled" - & inputElementConfig_initialValue .~ toAccountText - modalFooter $ do - cancel <- cancelButton def "No, take me back" - let cfg = def & uiButtonCfg_class <>~ "button_type_confirm" - next <- uiButtonDyn cfg $ text "Yes, proceed to transfer" - let ti2 = ti { _ti_toKeyset = Just $ UserKeyset (Set.singleton pk) KeysAll } - return ((mempty, close <> cancel), - (transferDialog model netInfo ti2 ty fks tks fromPair) <$ next) + return ((mempty, close <> cancel), + (transferDialog model netInfo ti2 ty fks tks fromPair) <$ next) + + multisigWF = case toLKS of + Just ks -> + let ti2 = ti { _ti_toKeyset = Just ks } + in transferDialog model netInfo ti2 ty fks tks fromPair + otherwise -> vanityWF + transferDialog :: ( MonadWidget t m, Monoid mConf From 0a7ef0862f76b8825af5f775bd3bdb2f922cfaa4 Mon Sep 17 00:00:00 2001 From: jmininger Date: Sat, 10 Sep 2022 10:36:51 -0400 Subject: [PATCH 6/7] debounce module-explorer --- frontend/src/Frontend/UI/ModuleExplorer/ModuleList.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/frontend/src/Frontend/UI/ModuleExplorer/ModuleList.hs b/frontend/src/Frontend/UI/ModuleExplorer/ModuleList.hs index 78fcf8c8..2b5ad20e 100644 --- a/frontend/src/Frontend/UI/ModuleExplorer/ModuleList.hs +++ b/frontend/src/Frontend/UI/ModuleExplorer/ModuleList.hs @@ -95,10 +95,8 @@ uiDeployedModuleList m mList = mdo & setValue .~ onNetworkName d <- uiDropdown Nothing opts filterCfg + onNewSearch <- debounce 0.2 $ _inputElement_input ti let - onNewSearch :: Event t Text - onNewSearch = _inputElement_input ti - onChainIdL :: Event t (Maybe ChainId) onChainIdL = _dropdown_change d From 2b794c25b6bce7c3469e6585478ffa1b61461751 Mon Sep 17 00:00:00 2001 From: jmininger Date: Tue, 13 Sep 2022 08:25:20 -0400 Subject: [PATCH 7/7] refactor --- common/src/Common/Wallet.hs | 4 ---- frontend/src/Frontend/UI/Transfer.hs | 3 +++ 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/common/src/Common/Wallet.hs b/common/src/Common/Wallet.hs index 9316f2b7..e0d67640 100644 --- a/common/src/Common/Wallet.hs +++ b/common/src/Common/Wallet.hs @@ -203,10 +203,6 @@ parsePubKeyOrKAccount :: AccountName -> (Bool, Either Text PublicKey) parsePubKeyOrKAccount (AccountName accName) = second parsePublicKey $ maybe (False, accName) (\k -> (True, k)) $ T.stripPrefix "k:" accName --- parsePrincipal :: AccountName -> Maybe Text --- parsePrincipal (AccountName accName) = --- T.stripPrefix "k:" accName <|> T.stripPrefix "w:" accName - throwDecodingErr :: MonadError Text m => Maybe v diff --git a/frontend/src/Frontend/UI/Transfer.hs b/frontend/src/Frontend/UI/Transfer.hs index 03810b64..f73cc075 100644 --- a/frontend/src/Frontend/UI/Transfer.hs +++ b/frontend/src/Frontend/UI/Transfer.hs @@ -459,6 +459,9 @@ lookupAndTransfer model netInfo ti ty onCloseExternal = do mAccs <- sample $ current $ Map.lookup <$> (model ^. network_selectedNetwork) <*> (fmap unAccountData $ model ^. wallet_accounts) + -- keysets for the to-account but on the chains not specified by the user + -- We use this for the case where the user needs to reconstruct a principal account name based + -- on data from other chains let toSimilarKeysets = constructKSFromOthers toAccount mAccs eWrapper (Just f, Just t) = do let fks = fromMaybe mempty f