diff --git a/common/src/Common/Wallet.hs b/common/src/Common/Wallet.hs index 99b912df9..571471889 100644 --- a/common/src/Common/Wallet.hs +++ b/common/src/Common/Wallet.hs @@ -21,6 +21,8 @@ module Common.Wallet , textToKey , keyToText , parsePublicKey + , parsePubKeyOrKAccount + , accountNameMatchesKeyset , toPactPublicKey , KeyPair(..) , AccountName(..) @@ -86,7 +88,7 @@ import Control.Monad.Except (MonadError, throwError) import Control.Newtype.Generics (Newtype (..)) import Data.Aeson import Data.Aeson.Types (toJSONKeyText) -import Data.Bifunctor (first) +import Data.Bifunctor (first, second) import Data.ByteString (ByteString) import Data.Decimal (Decimal, roundTo) import Data.Default @@ -187,6 +189,11 @@ decodeBase16M i = parsePublicKey :: MonadError Text m => Text -> m PublicKey parsePublicKey = throwDecodingErr . textToKey <=< checkPub . T.strip +-- (Is_k:acc, pubkey) +parsePubKeyOrKAccount :: AccountName -> (Bool, Either Text PublicKey) +parsePubKeyOrKAccount (AccountName accName) = + second parsePublicKey $ maybe (False, accName) (\k -> (True, k)) $ T.stripPrefix "k:" accName + throwDecodingErr :: MonadError Text m => Maybe v @@ -396,6 +403,20 @@ filterKeyPairs :: Set PublicKey -> IntMap (Key key) -> [KeyPair key] filterKeyPairs s m = Map.elems $ Map.restrictKeys (toMap m) s where toMap = Map.fromList . fmap (\k -> (_keyPair_publicKey $ _key_pair k, _key_pair k)) . IntMap.elems +-- Checks that all account names of form accName = pubkey has a single-key guard with the same pubkey as +-- account name +accountNameMatchesKeyset :: AccountName -> AccountGuard -> Bool +accountNameMatchesKeyset accName g = case g of + AccountGuard_Other _ -> False + AccountGuard_KeySetLike (KeySetHeritage ksKeys _ksPred _ksRef) -> + case parsePubKeyOrKAccount accName of + -- non-k: & non-vanity --> check keyset is singleton + (False, Right pk) -> ksKeys == Set.singleton pk + -- k: account name, we ignore the keyset and let those users + -- do what they want in regard to guards + (True, _) -> True + otherwise -> False + keysetSatisfiesPredicate :: AccountGuard -> IntMap (Key key) -> Bool keysetSatisfiesPredicate ag keys0 = case ag of AccountGuard_Other _ -> False diff --git a/frontend/src/Frontend/UI/Dialogs/AccountDetails.hs b/frontend/src/Frontend/UI/Dialogs/AccountDetails.hs index ae939cf9a..1d0958ede 100644 --- a/frontend/src/Frontend/UI/Dialogs/AccountDetails.hs +++ b/frontend/src/Frontend/UI/Dialogs/AccountDetails.hs @@ -7,6 +7,7 @@ module Frontend.UI.Dialogs.AccountDetails ( uiAccountDetailsOnChain , uiAccountDetails + , uiDisplayKeyset ) where import Control.Lens @@ -112,28 +113,13 @@ uiAccountDetailsOnChainImpl netname (name, chain, details, account) onClose = Wo case _account_status account of AccountStatus_Unknown -> text "Unknown" AccountStatus_DoesNotExist -> text "Does not exist" - AccountStatus_Exists d -> case _accountDetails_guard d of - AccountGuard_KeySetLike (KeySetHeritage ksKeys ksPred _ksRef) -> do - _ <- displayText "Predicate" ksPred "" - elClass "div" "segment segment_type_tertiary labeled-input" $ do - divClass "label labeled-input__label" $ text "Public Keys Controlling Account" - for_ ksKeys $ \key -> uiInputElement $ def - & initialAttributes %~ Map.insert "disabled" "disabled" . addToClassAttr "labeled-input__input labeled-input__multiple" - & inputElementConfig_initialValue .~ keyToText key - AccountGuard_Other g -> case g of - (Pact.GKeySetRef (Pact.KeySetName name)) -> do - void $ displayText "Name" name "" - _ -> void $ displayText (pactGuardTypeText $ Pact.guardTypeOf g) (renderCompactText g) "" - + AccountStatus_Exists d -> uiDisplayKeyset $ _accountDetails_guard d pure notesEdit - modalFooter $ do onDone <- confirmButton def "Done" - let onNotesUpdate = (netname, name, Just chain,) <$> current notesEdit <@ (onDone <> onClose) conf = mempty & walletCfg_updateAccountNotes .~ onNotesUpdate - pure ( ("Account Details", (conf, onDone)) , never ) @@ -157,6 +143,27 @@ uiAccountDetails net account notes onCloseExternal = mdo , leftmost [switch $ current dEvent, onClose] ) +uiDisplayKeyset :: MonadWidget t m => AccountGuard -> m () +uiDisplayKeyset guard = + let displayText lbl v cls = + let + attrFn cfg = uiInputElement $ cfg + & initialAttributes <>~ ("disabled" =: "true" <> "class" =: (" " <> cls)) + in + mkLabeledInputView False lbl attrFn $ pure v + in case guard of + AccountGuard_KeySetLike (KeySetHeritage ksKeys ksPred _ksRef) -> do + _ <- displayText "Predicate" ksPred "" + elClass "div" "segment segment_type_tertiary labeled-input" $ do + divClass "label labeled-input__label" $ text "Public Keys Controlling Account" + for_ ksKeys $ \key -> uiInputElement $ def + & initialAttributes %~ Map.insert "disabled" "disabled" . addToClassAttr "labeled-input__input labeled-input__multiple" + & inputElementConfig_initialValue .~ keyToText key + AccountGuard_Other g -> case g of + (Pact.GKeySetRef (Pact.KeySetName name)) -> do + void $ displayText "Name" name "" + _ -> void $ displayText (pactGuardTypeText $ Pact.guardTypeOf g) (renderCompactText g) "" + uiAccountDetailsImpl :: ( Monoid mConf , HasWalletCfg mConf key t diff --git a/frontend/src/Frontend/UI/Transfer.hs b/frontend/src/Frontend/UI/Transfer.hs index efd09eb9a..5e4edcae8 100644 --- a/frontend/src/Frontend/UI/Transfer.hs +++ b/frontend/src/Frontend/UI/Transfer.hs @@ -107,6 +107,7 @@ import Frontend.UI.Button import Frontend.UI.DeploymentSettings import Frontend.UI.Dialogs.DeployConfirmation import Frontend.UI.Dialogs.Send +import Frontend.UI.Dialogs.AccountDetails import Frontend.UI.Form.Common import Frontend.UI.FormWidget import Frontend.UI.KeysetWidget @@ -559,17 +560,43 @@ checkReceivingAccount model netInfo ti ty fks tks fromPair = do 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 = 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), + Workflow (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 transferDialog model netInfo ti2 ty fks tks fromPair - AccountGuard_Other _ -> transferDialog model netInfo ti ty fks tks fromPair + 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 - transferDialog model netInfo ti ty fks tks fromPair + transferDialogWithKeysetCheck model netInfo ti ty fks tks fromPair (_, Just userKeyset) -> do -- Use transfer-create transferDialog model netInfo ti ty fks tks fromPair @@ -597,10 +624,10 @@ handleMissingKeyset -> (AccountName, AccountDetails) -> m ((mConf, Event t ()), Event t (Workflow t m (mConf, Event t ()))) handleMissingKeyset model netInfo ti ty fks tks fromPair = do - let toAccountText = unAccountName $ _ca_account $ _ti_toAccount ti - parsePubKeyOrKAccount key = - second parsePublicKey $ maybe (False, key) (\k -> (True, k)) $ T.stripPrefix "k:" key - case parsePubKeyOrKAccount toAccountText of + let + toAccount = _ca_account $ _ti_toAccount ti + toAccountText = unAccountName $ _ca_account $ _ti_toAccount ti + case parsePubKeyOrKAccount toAccount of -- Vanity account name (_, Left _) -> do cancel <- fatalTransferError $