From 2510f81e322d8258a9e3db2b1fcb9693a7117476 Mon Sep 17 00:00:00 2001 From: Divam Date: Tue, 14 Dec 2021 16:46:07 +0900 Subject: [PATCH 01/11] Remove the cardano-crypto usage from ImportExport module --- desktop/src/Desktop/Crypto/BIP.hs | 3 -- desktop/src/Desktop/Frontend.hs | 3 +- desktop/src/Desktop/ImportExport.hs | 60 +++++++++++++++++++++-------- desktop/src/Desktop/Setup.hs | 6 ++- 4 files changed, 50 insertions(+), 22 deletions(-) diff --git a/desktop/src/Desktop/Crypto/BIP.hs b/desktop/src/Desktop/Crypto/BIP.hs index 4b431ef70..477e52353 100644 --- a/desktop/src/Desktop/Crypto/BIP.hs +++ b/desktop/src/Desktop/Crypto/BIP.hs @@ -72,9 +72,6 @@ data BIPStorage a where BIPStorage_RootKey :: BIPStorage Crypto.XPrv deriving instance Show (BIPStorage a) -bipMetaPrefix :: StoreKeyMetaPrefix -bipMetaPrefix = StoreKeyMetaPrefix "BIPStorage_Meta" - -- | Check the validity of the password by signing and verifying a message passwordRoundTripTest :: Crypto.XPrv -> Password -> Bool passwordRoundTripTest xprv (Password pass) = diff --git a/desktop/src/Desktop/Frontend.hs b/desktop/src/Desktop/Frontend.hs index 391507750..9baae0daf 100644 --- a/desktop/src/Desktop/Frontend.hs +++ b/desktop/src/Desktop/Frontend.hs @@ -30,6 +30,7 @@ import Data.Functor.Compose import Data.Functor.Identity import Data.GADT.Compare.TH import Data.Maybe (isJust) +import Data.Proxy (Proxy(..)) import Data.Text (Text) import Data.Time (NominalDiffTime, getCurrentTime, addUTCTime) import Data.Traversable (for) @@ -233,7 +234,7 @@ bipWallet fileFFI signingReq mkAppCfg = do let bOldPw = (\(Identity (_,oldPw)) -> oldPw) <$> current details runExport oldPw newPw = do pfx <- genZeroKeyPrefix - doExport txLogger pfx oldPw newPw + doExport txLogger pfx oldPw newPw (Proxy :: Proxy (BIPStorage Crypto.XPrv)) logExport = do ts <- liftIO getCurrentTime diff --git a/desktop/src/Desktop/ImportExport.hs b/desktop/src/Desktop/ImportExport.hs index 3a0e06a39..4565f3c28 100644 --- a/desktop/src/Desktop/ImportExport.hs +++ b/desktop/src/Desktop/ImportExport.hs @@ -2,22 +2,26 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE Rank2Types #-} module Desktop.ImportExport where -import qualified Cardano.Crypto.Wallet as Crypto import Control.Lens (over, mapped, _Left) import Control.Error (hoistEither, failWith) import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Except (ExceptT(ExceptT), runExceptT, throwError) import Control.Monad.Trans (lift) -import Data.Aeson (FromJSON, Value, eitherDecode, object, (.=), (.:), withObject) +import Data.Aeson (FromJSON, Value, eitherDecode, object, (.=), (.:), withObject, ToJSON) import Data.Aeson.Types (Parser, parseEither) import Data.Aeson.Text (encodeToLazyText) import Data.Bifunctor (first) +import Data.Constraint.Extras (Has) import Data.Foldable (traverse_) import Data.List (intercalate) +import Data.Proxy (Proxy) import Data.Dependent.Map (DMap) +import Data.GADT.Compare (GCompare) +import Data.GADT.Show (GShow) import qualified Data.Dependent.Map as DMap import Data.Time (getZonedTime, zonedTimeToLocalTime, iso8601DateFormat, formatTime) import Data.Functor.Identity (Identity, runIdentity) @@ -29,10 +33,9 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL import qualified Data.Text.Lazy.Encoding as TL +import Data.Universe.Some (UniverseSome) import Reflex -import Desktop.Orphans () -import Desktop.Crypto.BIP (BIPStorage(..), bipMetaPrefix, runBIPCryptoT, passwordRoundTripTest) import Frontend.AppCfg (ExportWalletError(..), FileType(FileType_Import), fileTypeExtension) import Pact.Server.ApiClient (WalletEvent (..), TransactionLogger (..)) import Frontend.Crypto.Class (HasCrypto) @@ -40,6 +43,7 @@ import Frontend.Wallet (PublicKeyPrefix (..), genZeroKeyPrefix) import Frontend.Storage (HasStorage, dumpLocalStorage) import Frontend.VersionedStore (VersionedStorage(..), StorageVersion, VersioningDecodeJsonError(..)) import qualified Frontend.VersionedStore as FrontendStore +import Frontend.Storage (StoreKeyMetaPrefix(..)) import Frontend.Crypto.Password data ImportWalletError @@ -67,6 +71,9 @@ storeFrontendDataKey = "StoreFrontend_Data" chainweaverImportObj :: String chainweaverImportObj = "ChainweaverImport" +bipMetaPrefix :: StoreKeyMetaPrefix +bipMetaPrefix = StoreKeyMetaPrefix "BIPStorage_Meta" + hoistParser :: Monad m => Text @@ -101,35 +108,45 @@ extractImportVersionField = extractImportDataField doImport - :: forall t m + :: forall t m n key bipStorage . ( MonadIO m , MonadJSM m , HasStorage m , MonadSample t m , Reflex t + , HasCrypto key (n m) + , MonadIO (n m) + , HasStorage (n m) + , FromJSON key + , ToJSON key + , FromJSON (DMap bipStorage Identity) + , GCompare bipStorage ) => TransactionLogger + -> bipStorage key + -> (key -> Password -> m Bool) + -> (forall a . () => key -> Password -> n m a -> m a) -> Password -> Text -- Backup data - -> m (Either ImportWalletError (Crypto.XPrv, Password)) -doImport txLogger pw contents = runExceptT $ do + -> m (Either ImportWalletError (key, Password)) +doImport txLogger bipStorageKey passwordRoundTripTest runF pw contents = runExceptT $ do jVal <- hoistEither . first (ImportWalletError_NotJson . T.pack) $ eitherDecode @Value (TL.encodeUtf8 . TL.fromStrict $ contents) bVer <- extractImportVersionField bipStorageVersionKey 0 jVal unless (bVer == 0) $ throwError $ ImportWalletError_UnknownVersion "BIPStorage" bVer - bipCrypto <- extractImportDataField @(DMap BIPStorage Identity) bipStorageDataKey 0 jVal - rootKey <- failWith ImportWalletError_NoRootKey (runIdentity <$> DMap.lookup BIPStorage_RootKey bipCrypto) + bipCrypto <- extractImportDataField @(DMap bipStorage Identity) bipStorageDataKey 0 jVal + rootKey <- failWith ImportWalletError_NoRootKey (runIdentity <$> DMap.lookup bipStorageKey bipCrypto) - let pwOk = passwordRoundTripTest rootKey pw + pwOk <- lift $ passwordRoundTripTest rootKey pw unless pwOk $ throwError ImportWalletError_PasswordIncorrect feVer <- extractImportVersionField storeFrontendVersionKey 0 jVal feData <- extractImportDataField @Value storeFrontendDataKey feVer jVal - _ <- ExceptT $ runBIPCryptoT (constant (rootKey, unPassword pw)) $ do - let vStore = FrontendStore.versionedStorage + _ <- ExceptT $ runF rootKey pw $ do + let vStore = FrontendStore.versionedStorage :: VersionedStorage (n m) (FrontendStore.StoreFrontend key) feLatestEither <- first (expandDecodeVersionJsonError storeFrontendDataKey feVer) <$> (_versionedStorage_decodeVersionedJson vStore feVer feData) @@ -151,25 +168,34 @@ doImport txLogger pw contents = runExceptT $ do ImportWalletError_UnknownVersion section ver doExport - :: forall m - . ( HasCrypto Crypto.XPrv m + :: forall m key bipStorage + . ( HasCrypto key m , MonadJSM m , HasStorage m + , FromJSON key + , ToJSON key + , HasCrypto key m + , ToJSON (DMap bipStorage Identity) + , Has FromJSON bipStorage + , GCompare bipStorage + , UniverseSome bipStorage + , GShow bipStorage ) => TransactionLogger -> PublicKeyPrefix -> Password -> Password + -> Proxy (bipStorage key) -> m (Either ExportWalletError (FilePath, Text)) -doExport txLogger keyPfx oldPw pw = runExceptT $ do +doExport txLogger keyPfx oldPw pw _ = runExceptT $ do unless (oldPw == pw) $ throwError ExportWalletError_PasswordIncorrect - let store = FrontendStore.versionedStorage @Crypto.XPrv @m + let store = FrontendStore.versionedStorage @key @m -- Trigger an upgrade of the storage to ensure we're exporting the latest version. _ <- ExceptT $ over (mapped . _Left) (const ExportWalletError_UpgradeFailed) $ _versionedStorage_upgradeStorage store txLogger - (bipVer,bipData) <- lift $ dumpLocalStorage @BIPStorage bipMetaPrefix + (bipVer,bipData) <- lift $ dumpLocalStorage @bipStorage bipMetaPrefix (feVer, feData) <- lift $ _versionedStorage_dumpLocalStorage store tl <- liftIO getCurrentLocale diff --git a/desktop/src/Desktop/Setup.hs b/desktop/src/Desktop/Setup.hs index 708c58c10..1f2f58e76 100644 --- a/desktop/src/Desktop/Setup.hs +++ b/desktop/src/Desktop/Setup.hs @@ -24,7 +24,9 @@ import qualified Data.Text as T import System.FilePath (takeFileName) import Frontend.AppCfg (FileFFI(..), FileType(FileType_Import)) +import Desktop.Crypto.BIP (BIPStorage(..), passwordRoundTripTest, runBIPCryptoT) import Desktop.ImportExport (doImport, ImportWalletError(..)) +import Desktop.Orphans () import Pact.Server.ApiClient (HasTransactionLogger, askTransactionLogger) import Frontend.Storage.Class (HasStorage) import Frontend.UI.Button @@ -197,7 +199,9 @@ restoreFromImport walletExists fileFFI backWF eBack = nagScreen <*> MaybeT (fmap snd <$> dFileSelected) txLogger <- askTransactionLogger - eImport <- performEvent $ tagMaybe (fmap (uncurry (doImport @t txLogger)) <$> current dmValidForm) eSubmit + let pwCheck k p= pure $ passwordRoundTripTest k p + runF k (Password p) = runBIPCryptoT (pure (k, p)) + eImport <- performEvent $ tagMaybe (fmap (uncurry (doImport @t txLogger BIPStorage_RootKey pwCheck runF)) <$> current dmValidForm) eSubmit let (eImportErr, eImportDone) = fanEither eImport From b7a371c612750d969105c812087772773ec75b79 Mon Sep 17 00:00:00 2001 From: Divam Date: Tue, 14 Dec 2021 16:52:27 +0900 Subject: [PATCH 02/11] Move ImportExport module to frontend --- desktop/desktop.cabal | 1 - desktop/src/Desktop/Frontend.hs | 2 +- desktop/src/Desktop/Setup.hs | 2 +- frontend/frontend.cabal | 1 + .../src/Desktop => frontend/src/Frontend/Setup}/ImportExport.hs | 2 +- 5 files changed, 4 insertions(+), 4 deletions(-) rename {desktop/src/Desktop => frontend/src/Frontend/Setup}/ImportExport.hs (99%) diff --git a/desktop/desktop.cabal b/desktop/desktop.cabal index 1a5883f06..77d4fdee1 100644 --- a/desktop/desktop.cabal +++ b/desktop/desktop.cabal @@ -60,7 +60,6 @@ library exposed-modules: Desktop.Crypto.BIP , Desktop.Frontend - , Desktop.ImportExport , Desktop.Orphans , Desktop.Setup , Desktop.Storage.File diff --git a/desktop/src/Desktop/Frontend.hs b/desktop/src/Desktop/Frontend.hs index 9baae0daf..c1471bdcc 100644 --- a/desktop/src/Desktop/Frontend.hs +++ b/desktop/src/Desktop/Frontend.hs @@ -70,10 +70,10 @@ import Frontend.VersionedStore (StoreFrontend(..)) import Frontend.Storage (runBrowserStorageT) import Frontend.Crypto.Password import Frontend.Setup.Common +import Frontend.Setup.ImportExport import Frontend.Setup.Password import Frontend.Setup.Widgets import Desktop.Setup -import Desktop.ImportExport import Desktop.Storage.File import Desktop.WalletApi diff --git a/desktop/src/Desktop/Setup.hs b/desktop/src/Desktop/Setup.hs index 1f2f58e76..4e3f158f7 100644 --- a/desktop/src/Desktop/Setup.hs +++ b/desktop/src/Desktop/Setup.hs @@ -25,7 +25,6 @@ import System.FilePath (takeFileName) import Frontend.AppCfg (FileFFI(..), FileType(FileType_Import)) import Desktop.Crypto.BIP (BIPStorage(..), passwordRoundTripTest, runBIPCryptoT) -import Desktop.ImportExport (doImport, ImportWalletError(..)) import Desktop.Orphans () import Pact.Server.ApiClient (HasTransactionLogger, askTransactionLogger) import Frontend.Storage.Class (HasStorage) @@ -34,6 +33,7 @@ import Frontend.UI.Widgets.Helpers (imgWithAlt) import Frontend.UI.Widgets import Frontend.Setup.Widgets import Frontend.Setup.Common +import Frontend.Setup.ImportExport (doImport, ImportWalletError(..)) import Frontend.Crypto.Password import Obelisk.Generated.Static diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal index e886e4f21..fb580e2ca 100644 --- a/frontend/frontend.cabal +++ b/frontend/frontend.cabal @@ -147,6 +147,7 @@ library , Frontend.Routes , Frontend.Setup.Browser , Frontend.Setup.Common + , Frontend.Setup.ImportExport , Frontend.Setup.Password , Frontend.Setup.Widgets , Frontend.Storage diff --git a/desktop/src/Desktop/ImportExport.hs b/frontend/src/Frontend/Setup/ImportExport.hs similarity index 99% rename from desktop/src/Desktop/ImportExport.hs rename to frontend/src/Frontend/Setup/ImportExport.hs index 4565f3c28..0924affe8 100644 --- a/desktop/src/Desktop/ImportExport.hs +++ b/frontend/src/Frontend/Setup/ImportExport.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE Rank2Types #-} -module Desktop.ImportExport where +module Frontend.Setup.ImportExport where import Control.Lens (over, mapped, _Left) import Control.Error (hoistEither, failWith) From ae481e62024a7cad07969eb637e799e6ee3150f9 Mon Sep 17 00:00:00 2001 From: Divam Date: Thu, 16 Dec 2021 11:55:22 +0900 Subject: [PATCH 03/11] Move the restoreFromImport widget to frontend --- desktop/src/Desktop/Setup.hs | 108 ++-------------------- frontend/src/Frontend/Setup/Common.hs | 124 +++++++++++++++++++++++++- 2 files changed, 127 insertions(+), 105 deletions(-) diff --git a/desktop/src/Desktop/Setup.hs b/desktop/src/Desktop/Setup.hs index 4e3f158f7..b409e57db 100644 --- a/desktop/src/Desktop/Setup.hs +++ b/desktop/src/Desktop/Setup.hs @@ -105,110 +105,12 @@ splashScreenWithImport walletExists fileFFI eBack = selfWF restoreImport <- uiButtonDyn (btnCfgSecondary & disabledCfg & restoreCfg) $ text "Restore from wallet export" + + let pwCheck k p= pure $ passwordRoundTripTest k p + runF k (Password p) = runBIPCryptoT (pure (k, p)) + finishSetupWF WalletScreen_SplashScreen $ leftmost [ createNewWallet selfWF eBack <$ hasAgreed create , restoreBipWallet selfWF eBack <$ hasAgreed restoreBipPhrase - , restoreFromImport walletExists fileFFI selfWF eBack <$ hasAgreed restoreImport + , restoreFromImport walletExists fileFFI BIPStorage_RootKey pwCheck runF selfWF eBack <$ hasAgreed restoreImport ] - -restoreFromImport - :: forall t m - . ( DomBuilder t m, MonadFix m, MonadHold t m, PerformEvent t m - , PostBuild t m, MonadJSM (Performable m), HasStorage (Performable m) - , MonadSample t (Performable m) - , HasTransactionLogger m - ) - => WalletExists - -> FileFFI t m - -> SetupWF Crypto.XPrv t m - -> Event t () - -> SetupWF Crypto.XPrv t m -restoreFromImport walletExists fileFFI backWF eBack = nagScreen - where - nagMsgs = case walletExists of - WalletExists_Yes -> - ("You are about to replace the current wallet's data" - ,"Reminder: Importing a wallet file will replace the data within the current wallet." - ) - WalletExists_No -> - ("Please select the wallet import file." - ,"Reminder: You will need your wallet password to proceed." - ) - - nagBack = case walletExists of - WalletExists_No -> pure never - WalletExists_Yes -> uiButtonDyn - -- TODO: Don't reuse this class or at least rename it - (btnCfgSecondary & uiButtonCfg_class <>~ "setup__restore-existing-button") - (text "Go back and export current wallet") - - nagScreen = Workflow $ setupDiv "splash" $ do - splashLogo - let (nagTitle, nagReminder) = nagMsgs - elClass "h1" "setup__recover-import-title" $ text nagTitle - elClass "p" "setup__recover-import-text" $ text nagReminder - eImport <- confirmButton def "Select Import File" - eExit <- nagBack - pure - ( (WalletScreen_RecoverImport, never, eExit) - , leftmost - [ backWF <$ (eBack <> eExit) - , importScreen <$ eImport - ] - ) - - importScreen = Workflow $ setupDiv "splash" $ mdo - splashLogo - elClass "h1" "setup__recover-import-title" $ text "Import File Password" - elClass "p" "setup__recover-import-text" $ text "Enter the password for the chosen wallet file in order to authorize access to the data." - - let disabled = isNothing <$> dmValidForm - dErr <- holdDyn Nothing (leftmost [Just <$> eImportErr, Nothing <$ updated dmValidForm]) - (eSubmit, (dFileSelected, pwInput)) <- setupForm "" "Import File" disabled $ mdo - ePb <- getPostBuild - (selectElt, _) <- elClass' "div" "setup__recover-import-file" $ do - imgWithAlt (static @"img/import.svg") "Import" blank - divClass "setup__recover-import-file-text" $ dynText $ ffor dFileSelected $ - maybe "Select a file" (T.pack . takeFileName . fst) - - performEvent_ $ liftJSM (_fileFFI_openFileDialog fileFFI FileType_Import) <$ - ((domEvent Click selectElt) <> ePb) - - dFileSelected <- holdDyn Nothing (Just <$> _fileFFI_externalFileOpened fileFFI) - - pw <- uiPassword (setupClass "password-wrapper") (setupClass "password") "Enter import wallet password" - - dyn_ $ ffor dErr $ traverse_ $ \err -> - elClass "p" "error_inline" $ text $ case err of - ImportWalletError_InvalidCommandLogDestination -> "Destination for transaction log file is invalid" - ImportWalletError_CommandLogWriteError -> "Unable to write transaction log file" - ImportWalletError_PasswordIncorrect -> "Incorrect Password" - ImportWalletError_NoRootKey -> "Backup cannot be restored as it does not contain a BIP Root Key" - ImportWalletError_NotJson eMsg -> "Backup cannot be restored as it is not a valid json file. Error: " <> eMsg - ImportWalletError_DecodeError section ver eMsg -> - "Backup section " <> section <> " cannot be parsed as version " <> tshow ver <> " with error: " <> eMsg - ImportWalletError_UnknownVersion section ver -> - "Backup section " <> section <> " has an unknown version " <> tshow ver <> ". It's likely that this backup is from a newer version of chainweaver." - - - pure (dFileSelected, pw) - - eExit <- nagBack - let dmValidForm = runMaybeT $ (,) - <$> MaybeT (nonEmptyPassword <$> (_inputElement_value pwInput)) - <*> MaybeT (fmap snd <$> dFileSelected) - - txLogger <- askTransactionLogger - let pwCheck k p= pure $ passwordRoundTripTest k p - runF k (Password p) = runBIPCryptoT (pure (k, p)) - eImport <- performEvent $ tagMaybe (fmap (uncurry (doImport @t txLogger BIPStorage_RootKey pwCheck runF)) <$> current dmValidForm) eSubmit - - let (eImportErr, eImportDone) = fanEither eImport - - pure - ( (WalletScreen_RecoverImport, (\(prv,pw) -> (prv, pw, False)) <$> eImportDone, eExit) - , backWF <$ (eBack <> eExit) - ) - - nonEmptyPassword "" = Nothing - nonEmptyPassword pw = Just (Password pw) diff --git a/frontend/src/Frontend/Setup/Common.hs b/frontend/src/Frontend/Setup/Common.hs index 327ff1896..9ab27b075 100644 --- a/frontend/src/Frontend/Setup/Common.hs +++ b/frontend/src/Frontend/Setup/Common.hs @@ -16,14 +16,22 @@ import Control.Error (hush) import Control.Monad (unless, void) import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT) +import Data.Aeson (FromJSON, ToJSON) import Data.Bool (bool) -import Data.Foldable (fold) +import Data.Dependent.Map (DMap) +import Data.Foldable (fold, traverse_) +import Data.Functor.Identity (Identity) +import Data.GADT.Compare (GCompare) import Data.Maybe (isNothing, isJust) import Data.Text (Text) import Language.Javascript.JSaddle (MonadJSM, liftJSM) import Reflex.Dom.Core import qualified Data.Map as Map import qualified Data.Text as T +import System.FilePath (takeFileName) + +import Pact.Server.ApiClient (HasTransactionLogger, askTransactionLogger) import Frontend.UI.Button import Frontend.UI.Dialogs.ChangePassword (minPasswordLength) @@ -31,8 +39,11 @@ import Frontend.UI.Widgets.Helpers (imgWithAlt) import Frontend.UI.Widgets import Obelisk.Generated.Static +import Frontend.AppCfg (FileFFI(..), FileType(FileType_Import)) +import Frontend.Setup.ImportExport import Frontend.Setup.Password import Frontend.Setup.Widgets +import Frontend.Storage.Class import Frontend.Crypto.Class import Frontend.Crypto.Password @@ -470,10 +481,119 @@ restoreBipWallet backWF eBack = Workflow $ do , backWF <$ eBack ) +restoreFromImport + :: forall t m n key bipStorage + . ( DomBuilder t m, MonadFix m, MonadHold t m, PerformEvent t m + , PostBuild t m, MonadJSM (Performable m), HasStorage (Performable m) + , MonadSample t (Performable m) + , HasTransactionLogger m + , HasCrypto key (n (Performable m)) + , MonadIO (n (Performable m)) + , HasStorage (n (Performable m)) + , FromJSON key + , ToJSON key + , FromJSON (DMap bipStorage Identity) + , GCompare bipStorage + ) + => WalletExists + -> FileFFI t m + -> bipStorage key + -> (key -> Password -> (Performable m) Bool) + -> (forall a . () => key -> Password -> n (Performable m) a -> (Performable m) a) + -> SetupWF key t m + -> Event t () + -> SetupWF key t m +restoreFromImport walletExists fileFFI bipStorageKey pwCheck runF backWF eBack = nagScreen + where + nagMsgs = case walletExists of + WalletExists_Yes -> + ("You are about to replace the current wallet's data" + ,"Reminder: Importing a wallet file will replace the data within the current wallet." + ) + WalletExists_No -> + ("Please select the wallet import file." + ,"Reminder: You will need your wallet password to proceed." + ) + + nagBack = case walletExists of + WalletExists_No -> pure never + WalletExists_Yes -> uiButtonDyn + -- TODO: Don't reuse this class or at least rename it + (btnCfgSecondary & uiButtonCfg_class <>~ "setup__restore-existing-button") + (text "Go back and export current wallet") + + nagScreen = Workflow $ setupDiv "splash" $ do + splashLogo + let (nagTitle, nagReminder) = nagMsgs + elClass "h1" "setup__recover-import-title" $ text nagTitle + elClass "p" "setup__recover-import-text" $ text nagReminder + eImport <- confirmButton def "Select Import File" + eExit <- nagBack + pure + ( (WalletScreen_RecoverImport, never, eExit) + , leftmost + [ backWF <$ (eBack <> eExit) + , importScreen <$ eImport + ] + ) + + importScreen = Workflow $ setupDiv "splash" $ mdo + splashLogo + elClass "h1" "setup__recover-import-title" $ text "Import File Password" + elClass "p" "setup__recover-import-text" $ text "Enter the password for the chosen wallet file in order to authorize access to the data." + + let disabled = isNothing <$> dmValidForm + dErr <- holdDyn Nothing (leftmost [Just <$> eImportErr, Nothing <$ updated dmValidForm]) + (eSubmit, (dFileSelected, pwInput)) <- setupForm "" "Import File" disabled $ mdo + ePb <- getPostBuild + (selectElt, _) <- elClass' "div" "setup__recover-import-file" $ do + imgWithAlt (static @"img/import.svg") "Import" blank + divClass "setup__recover-import-file-text" $ dynText $ ffor dFileSelected $ + maybe "Select a file" (T.pack . takeFileName . fst) + + performEvent_ $ liftJSM (_fileFFI_openFileDialog fileFFI FileType_Import) <$ + ((domEvent Click selectElt) <> ePb) + + dFileSelected <- holdDyn Nothing (Just <$> _fileFFI_externalFileOpened fileFFI) + + pw <- uiPassword (setupClass "password-wrapper") (setupClass "password") "Enter import wallet password" + + dyn_ $ ffor dErr $ traverse_ $ \err -> + elClass "p" "error_inline" $ text $ case err of + ImportWalletError_InvalidCommandLogDestination -> "Destination for transaction log file is invalid" + ImportWalletError_CommandLogWriteError -> "Unable to write transaction log file" + ImportWalletError_PasswordIncorrect -> "Incorrect Password" + ImportWalletError_NoRootKey -> "Backup cannot be restored as it does not contain a BIP Root Key" + ImportWalletError_NotJson eMsg -> "Backup cannot be restored as it is not a valid json file. Error: " <> eMsg + ImportWalletError_DecodeError section ver eMsg -> + "Backup section " <> section <> " cannot be parsed as version " <> tshow ver <> " with error: " <> eMsg + ImportWalletError_UnknownVersion section ver -> + "Backup section " <> section <> " has an unknown version " <> tshow ver <> ". It's likely that this backup is from a newer version of chainweaver." + + + pure (dFileSelected, pw) + + eExit <- nagBack + let dmValidForm = runMaybeT $ (,) + <$> MaybeT (nonEmptyPassword <$> (_inputElement_value pwInput)) + <*> MaybeT (fmap snd <$> dFileSelected) + + txLogger <- askTransactionLogger + eImport <- performEvent $ tagMaybe (fmap (uncurry (doImport @t txLogger bipStorageKey pwCheck runF)) <$> current dmValidForm) eSubmit + + let (eImportErr, eImportDone) = fanEither eImport + + pure + ( (WalletScreen_RecoverImport, (\(prv,pw) -> (prv, pw, False)) <$> eImportDone, eExit) + , backWF <$ (eBack <> eExit) + ) + + nonEmptyPassword "" = Nothing + nonEmptyPassword pw = Just (Password pw) + mkSidebarLogoutLink :: (TriggerEvent t m, PerformEvent t n, PostBuild t n, DomBuilder t n, MonadIO (Performable n)) => m (Event t (), n ()) mkSidebarLogoutLink = do (logout, triggerLogout) <- newTriggerEvent pure $ (,) logout $ do clk <- uiSidebarIcon (pure False) (static @"img/menu/logout.svg") "Logout" performEvent_ $ liftIO . triggerLogout <$> clk - From 06b7f991f1798171c76381fe33573965713bd7fa Mon Sep 17 00:00:00 2001 From: Divam Date: Thu, 16 Dec 2021 12:52:39 +0900 Subject: [PATCH 04/11] Refactor, add helper data type and constraints --- desktop/src/Desktop/Setup.hs | 5 ++-- frontend/src/Frontend/Setup/Common.hs | 16 +++--------- frontend/src/Frontend/Setup/ImportExport.hs | 27 ++++++++++++--------- 3 files changed, 23 insertions(+), 25 deletions(-) diff --git a/desktop/src/Desktop/Setup.hs b/desktop/src/Desktop/Setup.hs index b409e57db..9fa844865 100644 --- a/desktop/src/Desktop/Setup.hs +++ b/desktop/src/Desktop/Setup.hs @@ -33,7 +33,7 @@ import Frontend.UI.Widgets.Helpers (imgWithAlt) import Frontend.UI.Widgets import Frontend.Setup.Widgets import Frontend.Setup.Common -import Frontend.Setup.ImportExport (doImport, ImportWalletError(..)) +import Frontend.Setup.ImportExport (doImport, ImportWalletError(..), ImportWidgetApis(..)) import Frontend.Crypto.Password import Obelisk.Generated.Static @@ -108,9 +108,10 @@ splashScreenWithImport walletExists fileFFI eBack = selfWF let pwCheck k p= pure $ passwordRoundTripTest k p runF k (Password p) = runBIPCryptoT (pure (k, p)) + importWidgetApis = ImportWidgetApis BIPStorage_RootKey pwCheck runF finishSetupWF WalletScreen_SplashScreen $ leftmost [ createNewWallet selfWF eBack <$ hasAgreed create , restoreBipWallet selfWF eBack <$ hasAgreed restoreBipPhrase - , restoreFromImport walletExists fileFFI BIPStorage_RootKey pwCheck runF selfWF eBack <$ hasAgreed restoreImport + , restoreFromImport walletExists fileFFI importWidgetApis selfWF eBack <$ hasAgreed restoreImport ] diff --git a/frontend/src/Frontend/Setup/Common.hs b/frontend/src/Frontend/Setup/Common.hs index 9ab27b075..d56560d28 100644 --- a/frontend/src/Frontend/Setup/Common.hs +++ b/frontend/src/Frontend/Setup/Common.hs @@ -487,23 +487,15 @@ restoreFromImport , PostBuild t m, MonadJSM (Performable m), HasStorage (Performable m) , MonadSample t (Performable m) , HasTransactionLogger m - , HasCrypto key (n (Performable m)) - , MonadIO (n (Performable m)) - , HasStorage (n (Performable m)) - , FromJSON key - , ToJSON key - , FromJSON (DMap bipStorage Identity) - , GCompare bipStorage + , ImportWidgetConstraints bipStorage key n (Performable m) ) => WalletExists -> FileFFI t m - -> bipStorage key - -> (key -> Password -> (Performable m) Bool) - -> (forall a . () => key -> Password -> n (Performable m) a -> (Performable m) a) + -> ImportWidgetApis bipStorage key n (Performable m) -> SetupWF key t m -> Event t () -> SetupWF key t m -restoreFromImport walletExists fileFFI bipStorageKey pwCheck runF backWF eBack = nagScreen +restoreFromImport walletExists fileFFI importWidgetApis backWF eBack = nagScreen where nagMsgs = case walletExists of WalletExists_Yes -> @@ -579,7 +571,7 @@ restoreFromImport walletExists fileFFI bipStorageKey pwCheck runF backWF eBack = <*> MaybeT (fmap snd <$> dFileSelected) txLogger <- askTransactionLogger - eImport <- performEvent $ tagMaybe (fmap (uncurry (doImport @t txLogger bipStorageKey pwCheck runF)) <$> current dmValidForm) eSubmit + eImport <- performEvent $ tagMaybe (fmap (uncurry (doImport @t txLogger importWidgetApis)) <$> current dmValidForm) eSubmit let (eImportErr, eImportDone) = fanEither eImport diff --git a/frontend/src/Frontend/Setup/ImportExport.hs b/frontend/src/Frontend/Setup/ImportExport.hs index 0924affe8..ef71260c7 100644 --- a/frontend/src/Frontend/Setup/ImportExport.hs +++ b/frontend/src/Frontend/Setup/ImportExport.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ConstraintKinds #-} module Frontend.Setup.ImportExport where import Control.Lens (over, mapped, _Left) @@ -107,6 +108,18 @@ extractImportVersionField extractImportVersionField = extractImportDataField +data ImportWidgetApis bipStorage key n m = ImportWidgetApis + { _importWidgetApis_bipStorageKey :: bipStorage key + , _importWidgetApis_pwCheck :: (key -> Password -> m Bool) + , _importWidgetApis_runF :: (forall a . () => key -> Password -> n m a -> m a) + } + +type ImportWidgetConstraints bipStorage key n m = + ( MonadIO m, MonadIO (n m), HasCrypto key (n m), MonadIO (n m), + HasStorage (n m), FromJSON key, ToJSON key, FromJSON (DMap bipStorage Identity), + GCompare bipStorage + ) + doImport :: forall t m n key bipStorage . ( MonadIO m @@ -114,22 +127,14 @@ doImport , HasStorage m , MonadSample t m , Reflex t - , HasCrypto key (n m) - , MonadIO (n m) - , HasStorage (n m) - , FromJSON key - , ToJSON key - , FromJSON (DMap bipStorage Identity) - , GCompare bipStorage + , ImportWidgetConstraints bipStorage key n m ) => TransactionLogger - -> bipStorage key - -> (key -> Password -> m Bool) - -> (forall a . () => key -> Password -> n m a -> m a) + -> ImportWidgetApis bipStorage key n m -> Password -> Text -- Backup data -> m (Either ImportWalletError (key, Password)) -doImport txLogger bipStorageKey passwordRoundTripTest runF pw contents = runExceptT $ do +doImport txLogger (ImportWidgetApis bipStorageKey passwordRoundTripTest runF) pw contents = runExceptT $ do jVal <- hoistEither . first (ImportWalletError_NotJson . T.pack) $ eitherDecode @Value (TL.encodeUtf8 . TL.fromStrict $ contents) From 8a753d46cf744098946dc7a8e321d43438ad049f Mon Sep 17 00:00:00 2001 From: Divam Date: Thu, 16 Dec 2021 13:53:27 +0900 Subject: [PATCH 05/11] Remove Crypto.XPrv from Desktop.Setup module --- desktop/src/Desktop/Frontend.hs | 7 ++++++- desktop/src/Desktop/Setup.hs | 29 ++++++++++++++--------------- 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/desktop/src/Desktop/Frontend.hs b/desktop/src/Desktop/Frontend.hs index c1471bdcc..2d7a7ac5f 100644 --- a/desktop/src/Desktop/Frontend.hs +++ b/desktop/src/Desktop/Frontend.hs @@ -54,6 +54,7 @@ import Common.Route import Common.Wallet import Frontend.AppCfg import Desktop.Crypto.BIP +import Desktop.Orphans () import Frontend.ModuleExplorer.Impl (loadEditorFromLocalStorage) import Frontend.Log (defaultLogger) import Frontend.Wallet (genZeroKeyPrefix, _unPublicKeyPrefix) @@ -162,7 +163,11 @@ bipWallet fileFFI signingReq mkAppCfg = do -> WalletExists -> RoutedT t (R FrontendRoute) m (Event t (DSum LockScreen Identity)) runSetup0 mPrv walletExists = do - keyAndPass <- runSetup (liftFileFFI lift fileFFI) (isJust mPrv) walletExists + let pwCheck k p= pure $ passwordRoundTripTest k p + runF k (Password p) = runBIPCryptoT (pure (k, p)) + importWidgetApis = ImportWidgetApis BIPStorage_RootKey pwCheck runF + + keyAndPass <- runSetup (liftFileFFI lift fileFFI) (isJust mPrv) walletExists importWidgetApis performEvent $ flip push keyAndPass $ \case Right (x, Password p, newWallet) -> pure $ Just $ do setItemStorage localStorage BIPStorage_RootKey x diff --git a/desktop/src/Desktop/Setup.hs b/desktop/src/Desktop/Setup.hs index 9fa844865..3d22143ec 100644 --- a/desktop/src/Desktop/Setup.hs +++ b/desktop/src/Desktop/Setup.hs @@ -19,13 +19,10 @@ import Data.Foldable (traverse_) import Data.Maybe (isNothing) import Language.Javascript.JSaddle (MonadJSM, liftJSM) import Reflex.Dom.Core -import qualified Cardano.Crypto.Wallet as Crypto import qualified Data.Text as T import System.FilePath (takeFileName) import Frontend.AppCfg (FileFFI(..), FileType(FileType_Import)) -import Desktop.Crypto.BIP (BIPStorage(..), passwordRoundTripTest, runBIPCryptoT) -import Desktop.Orphans () import Pact.Server.ApiClient (HasTransactionLogger, askTransactionLogger) import Frontend.Storage.Class (HasStorage) import Frontend.UI.Button @@ -33,12 +30,13 @@ import Frontend.UI.Widgets.Helpers (imgWithAlt) import Frontend.UI.Widgets import Frontend.Setup.Widgets import Frontend.Setup.Common -import Frontend.Setup.ImportExport (doImport, ImportWalletError(..), ImportWidgetApis(..)) +import Frontend.Setup.ImportExport (doImport, ImportWalletError(..), ImportWidgetApis(..), ImportWidgetConstraints) +import Frontend.Crypto.Class import Frontend.Crypto.Password import Obelisk.Generated.Static runSetup - :: forall t m + :: forall t m n key bipStorage . ( DomBuilder t m , MonadFix m , MonadHold t m @@ -49,12 +47,15 @@ runSetup , HasStorage (Performable m) , MonadSample t (Performable m) , HasTransactionLogger m + , BIP39Root key, BIP39Mnemonic (Sentence key) + , ImportWidgetConstraints bipStorage key n (Performable m) ) => FileFFI t m -> Bool -> WalletExists - -> m (Event t (Either () (Crypto.XPrv, Password, Bool))) -runSetup fileFFI showBackOverride walletExists = setupDiv "fullscreen" $ mdo + -> ImportWidgetApis bipStorage key n (Performable m) + -> m (Event t (Either () (key, Password, Bool))) +runSetup fileFFI showBackOverride walletExists importWidgetApis = setupDiv "fullscreen" $ mdo let dCurrentScreen = (^._1) <$> dwf eBack <- fmap (domEvent Click . fst) $ elDynClass "div" ((setupClass "back " <>) . hideBack <$> dCurrentScreen) $ @@ -65,7 +66,7 @@ runSetup fileFFI showBackOverride walletExists = setupDiv "fullscreen" $ mdo _ <- dyn_ $ walletSetupRecoverHeader <$> dCurrentScreen dwf <- divClass "wrapper" $ - workflow (splashScreenWithImport walletExists fileFFI eBack) + workflow (splashScreenWithImport walletExists fileFFI importWidgetApis eBack) pure $ leftmost [ fmap Right $ switchDyn $ (^. _2) <$> dwf @@ -84,12 +85,15 @@ splashScreenWithImport , PostBuild t m, MonadJSM (Performable m), TriggerEvent t m, HasStorage (Performable m) , MonadSample t (Performable m) , HasTransactionLogger m + , BIP39Root key, BIP39Mnemonic (Sentence key) + , ImportWidgetConstraints bipStorage key n (Performable m) ) => WalletExists -> FileFFI t m + -> ImportWidgetApis bipStorage key n (Performable m) -> Event t () - -> SetupWF Crypto.XPrv t m -splashScreenWithImport walletExists fileFFI eBack = selfWF + -> SetupWF key t m +splashScreenWithImport walletExists fileFFI importWidgetApis eBack = selfWF where selfWF = Workflow $ setupDiv "splash" $ do agreed <- splashScreenAgreement @@ -105,11 +109,6 @@ splashScreenWithImport walletExists fileFFI eBack = selfWF restoreImport <- uiButtonDyn (btnCfgSecondary & disabledCfg & restoreCfg) $ text "Restore from wallet export" - - let pwCheck k p= pure $ passwordRoundTripTest k p - runF k (Password p) = runBIPCryptoT (pure (k, p)) - importWidgetApis = ImportWidgetApis BIPStorage_RootKey pwCheck runF - finishSetupWF WalletScreen_SplashScreen $ leftmost [ createNewWallet selfWF eBack <$ hasAgreed create , restoreBipWallet selfWF eBack <$ hasAgreed restoreBipPhrase From 245254743ce6caa0de2ec2a02a1fa44aabf98c37 Mon Sep 17 00:00:00 2001 From: Divam Date: Thu, 16 Dec 2021 13:58:51 +0900 Subject: [PATCH 06/11] Move the Desktop.Setup module to frontend --- desktop/desktop.cabal | 1 - desktop/src/Desktop/Frontend.hs | 2 +- frontend/frontend.cabal | 1 + {desktop/src/Desktop => frontend/src/Frontend/Setup}/Setup.hs | 2 +- 4 files changed, 3 insertions(+), 3 deletions(-) rename {desktop/src/Desktop => frontend/src/Frontend/Setup}/Setup.hs (98%) diff --git a/desktop/desktop.cabal b/desktop/desktop.cabal index 77d4fdee1..d0bf508c5 100644 --- a/desktop/desktop.cabal +++ b/desktop/desktop.cabal @@ -61,7 +61,6 @@ library Desktop.Crypto.BIP , Desktop.Frontend , Desktop.Orphans - , Desktop.Setup , Desktop.Storage.File , Desktop.Syslog , Desktop.WalletApi diff --git a/desktop/src/Desktop/Frontend.hs b/desktop/src/Desktop/Frontend.hs index 2d7a7ac5f..902c187e4 100644 --- a/desktop/src/Desktop/Frontend.hs +++ b/desktop/src/Desktop/Frontend.hs @@ -73,8 +73,8 @@ import Frontend.Crypto.Password import Frontend.Setup.Common import Frontend.Setup.ImportExport import Frontend.Setup.Password +import Frontend.Setup.Setup import Frontend.Setup.Widgets -import Desktop.Setup import Desktop.Storage.File import Desktop.WalletApi diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal index fb580e2ca..661eea386 100644 --- a/frontend/frontend.cabal +++ b/frontend/frontend.cabal @@ -149,6 +149,7 @@ library , Frontend.Setup.Common , Frontend.Setup.ImportExport , Frontend.Setup.Password + , Frontend.Setup.Setup , Frontend.Setup.Widgets , Frontend.Storage , Frontend.Storage.Class diff --git a/desktop/src/Desktop/Setup.hs b/frontend/src/Frontend/Setup/Setup.hs similarity index 98% rename from desktop/src/Desktop/Setup.hs rename to frontend/src/Frontend/Setup/Setup.hs index 3d22143ec..5d150fed1 100644 --- a/desktop/src/Desktop/Setup.hs +++ b/frontend/src/Frontend/Setup/Setup.hs @@ -9,7 +9,7 @@ {-# LANGUAGE TypeFamilies #-} -- | Wallet setup screens -module Desktop.Setup (runSetup) where +module Frontend.Setup.Setup (runSetup) where import Control.Lens ((<>~), (^.), _1, _2, _3) import Control.Monad (guard) From 88488e2f38e538394906caa77cbd327c8b0e1704 Mon Sep 17 00:00:00 2001 From: Divam Date: Thu, 16 Dec 2021 14:27:11 +0900 Subject: [PATCH 07/11] Use the runSetup from Setup module --- frontend/src/Frontend/Setup/Browser.hs | 72 ++------------------------ 1 file changed, 5 insertions(+), 67 deletions(-) diff --git a/frontend/src/Frontend/Setup/Browser.hs b/frontend/src/Frontend/Setup/Browser.hs index b74245fae..d7eb65f97 100644 --- a/frontend/src/Frontend/Setup/Browser.hs +++ b/frontend/src/Frontend/Setup/Browser.hs @@ -43,7 +43,9 @@ import Frontend.Crypto.Ed25519 import Frontend.Crypto.Browser import Frontend.Foundation import Frontend.Setup.Common +import Frontend.Setup.ImportExport import Frontend.Setup.Password +import Frontend.Setup.Setup import Frontend.Setup.Widgets import Frontend.Storage import Frontend.UI.Button @@ -77,72 +79,6 @@ type MkAppCfg t m -- ^ Settings -> AppCfg PrivateKey t (RoutedT t (R FrontendRoute) (BrowserCryptoT t m)) -runSetup - :: ( DomBuilder t m - , MonadFix m - , MonadHold t m - , PerformEvent t m - , PostBuild t m - , TriggerEvent t m - , MonadJSM (Performable m) - , HasStorage (Performable m) - , MonadSample t (Performable m) - , DerivableKey key mnemonic - ) - => FileFFI t m - -> Bool - -> WalletExists - -> m (Event t (Either () (key, Password, Bool))) -runSetup fileFFI showBackOverride walletExists = setupDiv "fullscreen" $ mdo - let dCurrentScreen = (^._1) <$> dwf - - eBack <- fmap (domEvent Click . fst) $ elDynClass "div" ((setupClass "back " <>) . hideBack <$> dCurrentScreen) $ - el' "span" $ do - elClass "i" "fa fa-fw fa-chevron-left" $ blank - text "Back" - - _ <- dyn_ $ walletSetupRecoverHeader <$> dCurrentScreen - - dwf <- divClass "wrapper" $ - workflow (splashScreenBrowser eBack) - - pure $ leftmost - [ fmap Right $ switchDyn $ (^. _2) <$> dwf - , attachWithMaybe (\s () -> Left () <$ guard (s == WalletScreen_SplashScreen)) (current dCurrentScreen) eBack - , fmap Left $ switchDyn $ (^. _3) <$> dwf - ] - where - hideBack ws = - if not showBackOverride && (ws `elem` [WalletScreen_SplashScreen, WalletScreen_Done]) then - setupClass "hide" - else - setupScreenClass ws - -splashScreenBrowser - :: (DomBuilder t m, MonadFix m, MonadHold t m, PerformEvent t m - , PostBuild t m, MonadJSM (Performable m), TriggerEvent t m, HasStorage (Performable m) - , MonadSample t (Performable m), DerivableKey key mnemonic - ) - => Event t () - -> SetupWF key t m -splashScreenBrowser eBack = selfWF - where - selfWF = Workflow $ setupDiv "splash" $ do - agreed <- splashScreenAgreement - let hasAgreed = gate (current agreed) - disabledCfg = uiButtonCfg_disabled .~ fmap not agreed - restoreCfg = uiButtonCfg_class <>~ "setup__restore-existing-button" - - create <- confirmButton (def & disabledCfg ) "Create a new wallet" - - restoreBipPhrase <- uiButtonDyn (btnCfgSecondary & disabledCfg & restoreCfg) - $ text "Restore from recovery phrase" - - finishSetupWF WalletScreen_SplashScreen $ leftmost - [ createNewWallet selfWF eBack <$ hasAgreed create - , restoreBipWallet selfWF eBack <$ hasAgreed restoreBipPhrase - ] - bipWalletBrowser :: forall js t m . ( MonadWidget t m @@ -172,7 +108,9 @@ bipWalletBrowser fileFFI mkAppCfg = do -> WalletExists -> RoutedT t (R FrontendRoute) m (Event t (DSum LockScreen Identity)) runSetup0 mPrv walletExists = do - keyAndPass <- runSetup (liftFileFFI lift fileFFI) (isJust mPrv) walletExists + let runF k p = runBrowserCryptoT (pure (k, p)) + importWidgetApis = ImportWidgetApis BIPStorage_RootKey passwordRoundTripTest runF + keyAndPass <- runSetup (liftFileFFI lift fileFFI) (isJust mPrv) walletExists importWidgetApis performEvent $ flip push keyAndPass $ \case Right (x, Password p, newWallet) -> pure $ Just $ do setItemStorage localStorage BIPStorage_RootKey x From 1841085274e383eeb1429fc49f28f5181331badc Mon Sep 17 00:00:00 2001 From: Divam Date: Thu, 16 Dec 2021 15:36:29 +0900 Subject: [PATCH 08/11] Implement fileFFI_deliverFile for browser using anchor tag based download --- frontend/src/Frontend.hs | 35 ++++++++++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/frontend/src/Frontend.hs b/frontend/src/Frontend.hs index f63a64252..b789a5524 100644 --- a/frontend/src/Frontend.hs +++ b/frontend/src/Frontend.hs @@ -5,19 +5,34 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE PackageImports #-} module Frontend where +import Control.Lens ((^.)) import Control.Monad (join, void) +import Control.Monad.Catch import Control.Monad.IO.Class +import Data.Coerce (coerce) import Data.Maybe (listToMaybe) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified GHCJS.DOM as DOM +import qualified GHCJS.DOM.Blob as Blob +import qualified "ghcjs-dom" GHCJS.DOM.Document as Document import qualified GHCJS.DOM.EventM as EventM import qualified GHCJS.DOM.FileReader as FileReader +import qualified GHCJS.DOM.HTMLAnchorElement as HTMLAnchorElement +import qualified GHCJS.DOM.HTMLBaseElement as HTMLBaseElement import qualified GHCJS.DOM.HTMLElement as HTMLElement import qualified GHCJS.DOM.HTMLInputElement as HTMLInput import qualified GHCJS.DOM.Types as Types import qualified GHCJS.DOM.File as JSFile +import qualified GHCJS.DOM.Node as Node +import qualified GHCJS.DOM.Types as DOM +import qualified GHCJS.DOM.URL as URL +import Foreign.JavaScript.Utils (bsToArrayBuffer) +import Language.Javascript.JSaddle (JSException(..), js0, js1, (<#), (!), valToText) import Reflex.Dom import Pact.Server.ApiClient (runTransactionLoggerT, noLogger) import Obelisk.Frontend @@ -72,7 +87,7 @@ frontend = Frontend let fileFFI = FileFFI { _fileFFI_externalFileOpened = fileOpened , _fileFFI_openFileDialog = liftJSM . triggerOpen - , _fileFFI_deliverFile = \_ -> pure never + , _fileFFI_deliverFile = triggerFileDownload } printResponsesHandler = pure $ FRPHandler never $ performEvent . fmap (liftIO . print) bipWalletBrowser fileFFI $ \enabledSettings -> AppCfg @@ -116,6 +131,24 @@ openFileDialog = do HTMLElement.click $ _inputElement_raw input pure (fmapMaybe id mContents, open) +triggerFileDownload :: (MonadJSM (Performable m), PerformEvent t m) + => Event t (FilePath, Text) -> m (Event t (Either Text FilePath)) +triggerFileDownload ev = performEvent $ ffor ev $ \(fileName, c) -> liftJSM $ catch (do + doc <- DOM.currentDocumentUnchecked + a :: HTMLAnchorElement.HTMLAnchorElement <- coerce <$> Document.createElement doc ("a" :: Text) + array <- bsToArrayBuffer (T.encodeUtf8 c) + blob <- Blob.newBlob [array] (Nothing :: Maybe DOM.BlobPropertyBag) + (url :: DOM.JSString) <- URL.createObjectURL blob + HTMLBaseElement.setHref (coerce a) url + HTMLAnchorElement.setDownload a fileName + body <- Document.getBodyUnchecked doc + void $ Node.appendChild body a + HTMLElement.click a + void $ Node.removeChild body a + URL.revokeObjectURL url + pure (Right fileName)) + (\(JSException e) -> valToText e >>= return . Left) + loaderMarkup :: DomBuilder t m => m () loaderMarkup = divClass "spinner" $ do divClass "spinner__cubes" $ do From f42943b431e6cb2a5274a1951ad8636858f4f17d Mon Sep 17 00:00:00 2001 From: Divam Date: Fri, 17 Dec 2021 14:30:14 +0900 Subject: [PATCH 09/11] Move the ExportWallet to frontend --- desktop/src/Desktop/Frontend.hs | 35 ++-------------- frontend/src/Frontend/Setup/Common.hs | 60 +++++++++++++++++++++++++-- 2 files changed, 61 insertions(+), 34 deletions(-) diff --git a/desktop/src/Desktop/Frontend.hs b/desktop/src/Desktop/Frontend.hs index 902c187e4..d48f07d30 100644 --- a/desktop/src/Desktop/Frontend.hs +++ b/desktop/src/Desktop/Frontend.hs @@ -24,7 +24,7 @@ import Control.Monad ((<=<), guard, void, when) import Control.Monad.Fix (MonadFix) import Control.Monad.Trans (lift) import Control.Monad.IO.Class -import Data.Bifunctor (first, second) +import Data.Bifunctor (second) import Data.Dependent.Sum import Data.Functor.Compose import Data.Functor.Identity @@ -57,7 +57,6 @@ import Desktop.Crypto.BIP import Desktop.Orphans () import Frontend.ModuleExplorer.Impl (loadEditorFromLocalStorage) import Frontend.Log (defaultLogger) -import Frontend.Wallet (genZeroKeyPrefix, _unPublicKeyPrefix) import Frontend.Storage import Frontend.UI.Modal.Impl (showModalBrutal) import Frontend.UI.Dialogs.LogoutConfirmation (uiIdeLogoutConfirmation) @@ -234,35 +233,9 @@ bipWallet fileFFI signingReq mkAppCfg = do -- the new root , _changePassword_updateKeys = ((second Password) <$> updates, changePasswordDesktopAction) } - , _enabledSettings_exportWallet = Just $ ExportWallet - { _exportWallet_requestExport = \ePw -> do - let bOldPw = (\(Identity (_,oldPw)) -> oldPw) <$> current details - runExport oldPw newPw = do - pfx <- genZeroKeyPrefix - doExport txLogger pfx oldPw newPw (Proxy :: Proxy (BIPStorage Crypto.XPrv)) - - logExport = do - ts <- liftIO getCurrentTime - sender <- genZeroKeyPrefix - liftIO $ _transactionLogger_walletEvent txLogger - WalletEvent_Export - (_unPublicKeyPrefix sender) - ts - - eExport <- performEvent $ runExport - <$> (Password <$> bOldPw) - <@> (Password <$> ePw) - - let (eErrExport, eGoodExport) = fanEither eExport - - eFileDone <- _fileFFI_deliverFile frontendFileFFI eGoodExport - eLogExportDone <- performEvent $ (\r -> r <$ logExport) <$> eFileDone - - pure $ leftmost - [ Left <$> eErrExport - , first ExportWalletError_FileNotWritable <$> eLogExportDone - ] - } + , _enabledSettings_exportWallet = + let details' = fmap (\(k, p) -> (k, Password p)) <$> details + in Just $ mkExportWallet txLogger frontendFileFFI details' (Proxy :: Proxy (BIPStorage Crypto.XPrv)) , _enabledSettings_transactionLog = True } diff --git a/frontend/src/Frontend/Setup/Common.hs b/frontend/src/Frontend/Setup/Common.hs index d56560d28..5d91d3c1a 100644 --- a/frontend/src/Frontend/Setup/Common.hs +++ b/frontend/src/Frontend/Setup/Common.hs @@ -18,20 +18,26 @@ import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT) import Data.Aeson (FromJSON, ToJSON) +import Data.Bifunctor (first) import Data.Bool (bool) +import Data.Constraint.Extras (Has) import Data.Dependent.Map (DMap) import Data.Foldable (fold, traverse_) -import Data.Functor.Identity (Identity) +import Data.Functor.Identity (Identity(..)) import Data.GADT.Compare (GCompare) +import Data.GADT.Show (GShow) import Data.Maybe (isNothing, isJust) +import Data.Proxy (Proxy(..)) import Data.Text (Text) +import Data.Time (getCurrentTime) +import Data.Universe.Some (UniverseSome) import Language.Javascript.JSaddle (MonadJSM, liftJSM) import Reflex.Dom.Core import qualified Data.Map as Map import qualified Data.Text as T import System.FilePath (takeFileName) -import Pact.Server.ApiClient (HasTransactionLogger, askTransactionLogger) +import Pact.Server.ApiClient (HasTransactionLogger, TransactionLogger(..), WalletEvent(..), askTransactionLogger) import Frontend.UI.Button import Frontend.UI.Dialogs.ChangePassword (minPasswordLength) @@ -39,13 +45,14 @@ import Frontend.UI.Widgets.Helpers (imgWithAlt) import Frontend.UI.Widgets import Obelisk.Generated.Static -import Frontend.AppCfg (FileFFI(..), FileType(FileType_Import)) +import Frontend.AppCfg (FileFFI(..), FileType(FileType_Import), ExportWallet(..), ExportWalletError(..)) import Frontend.Setup.ImportExport import Frontend.Setup.Password import Frontend.Setup.Widgets import Frontend.Storage.Class import Frontend.Crypto.Class import Frontend.Crypto.Password +import Frontend.Wallet (genZeroKeyPrefix, _unPublicKeyPrefix) -- | Used for changing the settings in the passphrase widget. data PassphraseStage @@ -589,3 +596,50 @@ mkSidebarLogoutLink = do pure $ (,) logout $ do clk <- uiSidebarIcon (pure False) (static @"img/menu/logout.svg") "Logout" performEvent_ $ liftIO . triggerLogout <$> clk + +mkExportWallet :: + ( PerformEvent t m + , HasCrypto key (Performable m) + , MonadJSM (Performable m) + , HasStorage (Performable m) + , FromJSON key + , ToJSON key + , ToJSON (DMap bipStorage Identity) + , Has FromJSON bipStorage + , GCompare bipStorage + , UniverseSome bipStorage + , GShow bipStorage + ) + => TransactionLogger + -> FileFFI t m + -> Dynamic t (Identity (key, Password)) + -> Proxy (bipStorage key) + -> ExportWallet t m +mkExportWallet txLogger frontendFileFFI details proxy = ExportWallet + { _exportWallet_requestExport = \ePw -> do + let bOldPw = (\(Identity (_,oldPw)) -> oldPw) <$> current details + runExport oldPw newPw = do + pfx <- genZeroKeyPrefix + doExport txLogger pfx oldPw newPw proxy + + logExport = do + ts <- liftIO getCurrentTime + sender <- genZeroKeyPrefix + liftIO $ _transactionLogger_walletEvent txLogger + WalletEvent_Export + (_unPublicKeyPrefix sender) + ts + + eExport <- performEvent $ runExport + <$> bOldPw <@> (Password <$> ePw) + + let (eErrExport, eGoodExport) = fanEither eExport + + eFileDone <- _fileFFI_deliverFile frontendFileFFI eGoodExport + eLogExportDone <- performEvent $ (\r -> r <$ logExport) <$> eFileDone + + pure $ leftmost + [ Left <$> eErrExport + , first ExportWalletError_FileNotWritable <$> eLogExportDone + ] + } From 87f30dfe651d894734f7bb41747a045cf4938dda Mon Sep 17 00:00:00 2001 From: Divam Date: Fri, 17 Dec 2021 14:30:46 +0900 Subject: [PATCH 10/11] Add ExportWallet to the web app --- frontend/src/Frontend/Setup/Browser.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/frontend/src/Frontend/Setup/Browser.hs b/frontend/src/Frontend/Setup/Browser.hs index d7eb65f97..75b171ae4 100644 --- a/frontend/src/Frontend/Setup/Browser.hs +++ b/frontend/src/Frontend/Setup/Browser.hs @@ -12,7 +12,6 @@ -- | Wallet setup screens module Frontend.Setup.Browser (runSetup, bipWalletBrowser) where -import Control.Lens ((<>~), (^.), _1, _2, _3) import Control.Monad (guard) import Control.Monad.Fix (MonadFix) import Control.Monad.Trans (lift) @@ -26,13 +25,13 @@ import Data.Functor.Compose import Data.Functor.Identity import Data.GADT.Compare.TH import Data.GADT.Show.TH +import Data.Proxy (Proxy(..)) import Data.Traversable (for) import Data.Universe.Some.TH import Language.Javascript.JSaddle (MonadJSM) import Reflex.Dom.Core hiding (Key) -import Pact.Server.ApiClient (HasTransactionLogger, askTransactionLogger, _transactionLogger_rotateLogFile) +import Pact.Server.ApiClient (HasTransactionLogger, TransactionLogger, askTransactionLogger, _transactionLogger_rotateLogFile) import Obelisk.Route.Frontend -import Obelisk.Generated.Static import Common.Wallet import Common.Route import qualified Frontend.App as App (app) @@ -152,7 +151,7 @@ bipWalletBrowser fileFFI mkAppCfg = do (updates, trigger) <- newTriggerEvent let frontendFileFFI = liftFileFFI (lift . lift) fileFFI App.app sidebarLogoutLink frontendFileFFI $ mkAppCfg $ - appSettingsBrowser trigger details updates changePasswordBrowserAction + appSettingsBrowser txLogger frontendFileFFI trigger details updates changePasswordBrowserAction setRoute $ landingPageRoute <$ onLogoutConfirm pure $ leftmost @@ -166,20 +165,23 @@ appSettingsBrowser :: , HasStorage (Performable m) , PerformEvent t m , MonadJSM (Performable m) + , HasCrypto PrivateKey (Performable m) ) - => ((PrivateKey, Password) -> IO ()) + => TransactionLogger + -> FileFFI t m + -> ((PrivateKey, Password) -> IO ()) -> Dynamic t (Identity (PrivateKey, Password)) -> Event t (PrivateKey, Password) -> (Int -> PrivateKey -> Password -> (Performable m) (Key PrivateKey)) -> EnabledSettings PrivateKey t m -appSettingsBrowser newPwdTrigger details keyUpdates changePasswordBrowserAction = EnabledSettings +appSettingsBrowser txLogger frontendFileFFI newPwdTrigger details keyUpdates changePasswordBrowserAction = EnabledSettings { _enabledSettings_changePassword = Just $ ChangePassword { _changePassword_requestChange = performEvent . attachWith doChange (current details) -- When updating the keys here, we just always regenerate the key from -- the new root , _changePassword_updateKeys = (keyUpdates, changePasswordBrowserAction) } - , _enabledSettings_exportWallet = Nothing + , _enabledSettings_exportWallet = Just $ mkExportWallet txLogger frontendFileFFI details (Proxy :: Proxy (BIPStorage PrivateKey)) , _enabledSettings_transactionLog = False } where From 977404c0a640f33c24d677063cf6280069551526 Mon Sep 17 00:00:00 2001 From: Divam Date: Tue, 21 Dec 2021 19:11:32 +0900 Subject: [PATCH 11/11] Use 'defaultTimeLocale' in doExport as getCurrentLocale does not work with ghcjs --- frontend/src/Frontend/Setup/ImportExport.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/frontend/src/Frontend/Setup/ImportExport.hs b/frontend/src/Frontend/Setup/ImportExport.hs index ef71260c7..4f346f551 100644 --- a/frontend/src/Frontend/Setup/ImportExport.hs +++ b/frontend/src/Frontend/Setup/ImportExport.hs @@ -27,8 +27,7 @@ import qualified Data.Dependent.Map as DMap import Data.Time (getZonedTime, zonedTimeToLocalTime, iso8601DateFormat, formatTime) import Data.Functor.Identity (Identity, runIdentity) import Language.Javascript.JSaddle (MonadJSM) -import Data.Time (getCurrentTime) -import System.Locale.Read (getCurrentLocale) +import Data.Time (getCurrentTime, defaultTimeLocale) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -203,14 +202,13 @@ doExport txLogger keyPfx oldPw pw _ = runExceptT $ do (bipVer,bipData) <- lift $ dumpLocalStorage @bipStorage bipMetaPrefix (feVer, feData) <- lift $ _versionedStorage_dumpLocalStorage store - tl <- liftIO getCurrentLocale lt <- zonedTimeToLocalTime <$> liftIO getZonedTime pure $ ( intercalate "." [ T.unpack $ _unPublicKeyPrefix keyPfx -- Mac does something weird with colons in the name and converts them to subdirs... - , formatTime tl (iso8601DateFormat (Just "%H-%M-%S")) lt + , formatTime defaultTimeLocale (iso8601DateFormat (Just "%H-%M-%S")) lt , T.unpack (fileTypeExtension FileType_Import) ] , TL.toStrict $ encodeToLazyText $ object $