diff --git a/wallet-new/cardano-sl-wallet-new.cabal b/wallet-new/cardano-sl-wallet-new.cabal index 6a8ec33987e..01365e9c972 100755 --- a/wallet-new/cardano-sl-wallet-new.cabal +++ b/wallet-new/cardano-sl-wallet-new.cabal @@ -72,7 +72,6 @@ library Cardano.Wallet.Kernel.Addresses Cardano.Wallet.Kernel.BIP39 Cardano.Wallet.Kernel.BListener - Cardano.Wallet.Kernel.ChainState Cardano.Wallet.Kernel.CoinSelection Cardano.Wallet.Kernel.CoinSelection.FromGeneric Cardano.Wallet.Kernel.CoinSelection.Generic @@ -81,6 +80,7 @@ library Cardano.Wallet.Kernel.CoinSelection.Generic.LargestFirst Cardano.Wallet.Kernel.CoinSelection.Generic.Random Cardano.Wallet.Kernel.DB.AcidState + Cardano.Wallet.Kernel.DB.BlockContext Cardano.Wallet.Kernel.DB.BlockMeta Cardano.Wallet.Kernel.DB.HdWallet Cardano.Wallet.Kernel.DB.HdWallet.Create @@ -101,6 +101,7 @@ library Cardano.Wallet.Kernel.DB.Updates Cardano.Wallet.Kernel.DB.Util.AcidState Cardano.Wallet.Kernel.DB.Util.IxSet + Cardano.Wallet.Kernel.Decrypt Cardano.Wallet.Kernel.Diffusion Cardano.Wallet.Kernel.Internal Cardano.Wallet.Kernel.Invariants @@ -110,6 +111,7 @@ library Cardano.Wallet.Kernel.Pending Cardano.Wallet.Kernel.PrefilterTx Cardano.Wallet.Kernel.Read + Cardano.Wallet.Kernel.Restore Cardano.Wallet.Kernel.Submission Cardano.Wallet.Kernel.Submission.Worker Cardano.Wallet.Kernel.Transactions diff --git a/wallet-new/src/Cardano/Wallet/Kernel.hs b/wallet-new/src/Cardano/Wallet/Kernel.hs index 5c14dc6f92f..c08ada0daf4 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel.hs @@ -93,13 +93,15 @@ initPassiveWallet :: (Severity -> Text -> IO ()) -> IO PassiveWallet initPassiveWallet logMessage keystore Handles{..} node = do submission <- newMVar (newWalletSubmission rho) + restore <- newMVar Map.empty return PassiveWallet { - _walletLogMessage = logMessage - , _walletKeystore = keystore - , _wallets = hAcid - , _walletMeta = hMeta - , _walletNode = node - , _walletSubmission = submission + _walletLogMessage = logMessage + , _walletKeystore = keystore + , _wallets = hAcid + , _walletMeta = hMeta + , _walletNode = node + , _walletSubmission = submission + , _walletRestorationTask = restore } where rho = defaultResubmitFunction (exponentialBackoff 255 1.25) diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Accounts.hs b/wallet-new/src/Cardano/Wallet/Kernel/Accounts.hs index c1ba76f8f38..f8340db5c82 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Accounts.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Accounts.hs @@ -22,12 +22,13 @@ import Cardano.Wallet.Kernel.DB.AcidState (CreateHdAccount (..), DB, DeleteHdAccount (..), UpdateHdAccountName (..)) import Cardano.Wallet.Kernel.DB.HdWallet (AccountName (..), HdAccount (..), HdAccountId (..), HdAccountIx (..), - HdRootId, UnknownHdAccount (..), hdAccountName) + HdAccountState (..), HdAccountUpToDate (..), HdRootId, + UnknownHdAccount (..), hdAccountName) import Cardano.Wallet.Kernel.DB.HdWallet.Create (CreateHdAccountError (..), initHdAccount) import Cardano.Wallet.Kernel.DB.HdWallet.Derivation (HardeningMode (..), deriveIndex) -import Cardano.Wallet.Kernel.DB.Spec (Checkpoint, initCheckpoint) +import Cardano.Wallet.Kernel.DB.Spec (initCheckpoint) import Cardano.Wallet.Kernel.Internal (PassiveWallet, walletKeystore, wallets) import qualified Cardano.Wallet.Kernel.Keystore as Keystore @@ -115,7 +116,7 @@ createHdRndAccount _spendingPassword accountName _esk rootId pw = do tryGenerateAccount gen collisions = do newIndex <- deriveIndex (flip uniformR gen) HdAccountIx HardDerivation let hdAccountId = HdAccountId rootId newIndex - newAccount = initHdAccount hdAccountId firstCheckpoint & + newAccount = initHdAccount hdAccountId initState & hdAccountName .~ accountName db = pw ^. wallets res <- update db (CreateHdAccount newAccount) @@ -136,9 +137,11 @@ createHdRndAccount _spendingPassword accountName _esk rootId pw = do maxAllowedCollisions :: Word32 maxAllowedCollisions = 42 - -- | The first 'Checkpoint' known to this 'Account'. - firstCheckpoint :: Checkpoint - firstCheckpoint = initCheckpoint mempty + -- Initial account state + initState :: HdAccountState + initState = HdAccountStateUpToDate HdAccountUpToDate { + _hdUpToDateCheckpoints = one $ initCheckpoint mempty + } -- | Deletes an HD 'Account' from the data storage. deleteAccount :: HdAccountId diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Addresses.hs b/wallet-new/src/Cardano/Wallet/Kernel/Addresses.hs index b088dcc5e4c..6a026edfdd6 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Addresses.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Addresses.hs @@ -27,7 +27,6 @@ import Cardano.Wallet.Kernel.DB.HdWallet.Create (CreateHdAddressError (..), initHdAddress) import Cardano.Wallet.Kernel.DB.HdWallet.Derivation (HardeningMode (..), deriveIndex) -import Cardano.Wallet.Kernel.DB.InDb (InDb (..)) import Cardano.Wallet.Kernel.Internal (PassiveWallet, walletKeystore, wallets) import qualified Cardano.Wallet.Kernel.Keystore as Keystore @@ -144,7 +143,7 @@ createHdRndAddress spendingPassword esk accId pw = do case mbAddr of Nothing -> return (Left $ CreateAddressHdRndGenerationFailed accId) Just (newAddress, _) -> do - let hdAddress = initHdAddress hdAddressId (InDb newAddress) + let hdAddress = initHdAddress hdAddressId newAddress let db = pw ^. wallets res <- update db (CreateHdAddress hdAddress) case res of diff --git a/wallet-new/src/Cardano/Wallet/Kernel/BListener.hs b/wallet-new/src/Cardano/Wallet/Kernel/BListener.hs index f5f501bfb34..f64151b7562 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/BListener.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/BListener.hs @@ -2,7 +2,6 @@ module Cardano.Wallet.Kernel.BListener ( -- * Respond to block chain events applyBlock - , applyBlocks , switchToFork -- * Testing , observableRollbackUseInTestsOnly @@ -13,16 +12,15 @@ import Universum hiding (State) import Control.Concurrent.MVar (modifyMVar_) import Data.Acid.Advanced (update') -import Pos.Core (SlotId) -import Pos.Core.Chrono (OldestFirst) import Pos.Crypto (EncryptedSecretKey) import Cardano.Wallet.Kernel.DB.AcidState (ApplyBlock (..), - ObservableRollbackUseInTestsOnly (..), - RollbackDuringRestoration, SwitchToFork (..)) + ObservableRollbackUseInTestsOnly (..), SwitchToFork (..), + SwitchToForkError (..)) +import Cardano.Wallet.Kernel.DB.BlockContext import Cardano.Wallet.Kernel.DB.HdWallet -import Cardano.Wallet.Kernel.DB.InDb -import Cardano.Wallet.Kernel.DB.Resolved (ResolvedBlock, rbSlotId) +import Cardano.Wallet.Kernel.DB.Resolved (ResolvedBlock, rbContext) +import Cardano.Wallet.Kernel.DB.Spec.Update (ApplyBlockFailed) import Cardano.Wallet.Kernel.DB.TxMeta.Types import Cardano.Wallet.Kernel.Internal import qualified Cardano.Wallet.Kernel.NodeStateAdaptor as Node @@ -41,35 +39,31 @@ import Cardano.Wallet.Kernel.Types (WalletId (..)) -- TODO: Improve performance (CBR-379) prefilterBlock' :: PassiveWallet -> ResolvedBlock - -> IO ((SlotId, Map HdAccountId PrefilteredBlock), [TxMeta]) + -> IO ((BlockContext, Map HdAccountId PrefilteredBlock), [TxMeta]) prefilterBlock' pw b = do aux <$> getWalletCredentials pw where aux :: [(WalletId, EncryptedSecretKey)] - -> ((SlotId, Map HdAccountId PrefilteredBlock), [TxMeta]) + -> ((BlockContext, Map HdAccountId PrefilteredBlock), [TxMeta]) aux ws = let (conMap, conMeta) = mconcat $ map (uncurry (prefilterBlock b)) ws - in ((b ^. rbSlotId, conMap), conMeta) + in ((b ^. rbContext, conMap), conMeta) -- | Notify all the wallets in the PassiveWallet of a new block applyBlock :: PassiveWallet -> ResolvedBlock - -> IO () + -> IO (Either ApplyBlockFailed ()) applyBlock pw@PassiveWallet{..} b = do k <- Node.getSecurityParameter _walletNode - ((slotId, blocksByAccount), metas) <- prefilterBlock' pw b + ((ctxt, blocksByAccount), metas) <- prefilterBlock' pw b -- apply block to all Accounts in all Wallets - confirmed <- update' _wallets $ ApplyBlock k (InDb slotId) blocksByAccount - modifyMVar_ _walletSubmission $ return . Submission.remPending confirmed - mapM_ (putTxMeta _walletMeta) metas - --- | Apply multiple blocks, one at a time, to all wallets in the PassiveWallet --- --- TODO(@matt-noonan) this will be the responsibility of the worker thread (as part of CBR-243: Wallet restoration) -applyBlocks :: PassiveWallet - -> OldestFirst [] ResolvedBlock - -> IO () -applyBlocks = mapM_ . applyBlock + mConfirmed <- update' _wallets $ ApplyBlock k ctxt blocksByAccount + case mConfirmed of + Left err -> return $ Left err + Right confirmed -> do + modifyMVar_ _walletSubmission $ return . Submission.remPending confirmed + mapM_ (putTxMeta _walletMeta) metas + return $ Right () -- | Switch to a new fork -- @@ -78,7 +72,7 @@ applyBlocks = mapM_ . applyBlock switchToFork :: PassiveWallet -> Int -- ^ Number of blocks to roll back -> [ResolvedBlock] -- ^ Blocks in the new fork - -> IO (Either RollbackDuringRestoration ()) + -> IO (Either SwitchToForkError ()) switchToFork pw@PassiveWallet{..} n bs = do k <- Node.getSecurityParameter _walletNode blocksAndMeta <- mapM (prefilterBlock' pw) bs @@ -98,7 +92,7 @@ switchToFork pw@PassiveWallet{..} n bs = do -- Only used for tests. See 'switchToFork'. -- TODO(kde): Do we want tests to deal with metadata? observableRollbackUseInTestsOnly :: PassiveWallet - -> IO (Either RollbackDuringRestoration ()) + -> IO (Either SwitchToForkError ()) observableRollbackUseInTestsOnly PassiveWallet{..} = do res <- update' _wallets $ ObservableRollbackUseInTestsOnly case res of diff --git a/wallet-new/src/Cardano/Wallet/Kernel/ChainState.hs b/wallet-new/src/Cardano/Wallet/Kernel/ChainState.hs deleted file mode 100644 index 14fa0b33236..00000000000 --- a/wallet-new/src/Cardano/Wallet/Kernel/ChainState.hs +++ /dev/null @@ -1,305 +0,0 @@ -module Cardano.Wallet.Kernel.ChainState ( - -- * Chain state and state modifier - ChainState(..) - , ChainStateModifier(..) - , fromCPS - , applyChainStateModifier - -- * Chain brief - , ChainBrief(..) - , getChainBrief - , chainBriefSucceeds - -- * Restoration - , ChainStateRestoration(..) - , getChainStateRestoration - ) where - -import Universum - -import qualified Data.Map.Strict as Map - -import Pos.Chain.Block (HeaderHash, gbHeader, headerHash, - mainBlockSlot, prevBlockL) -import Pos.Chain.Update (BlockVersionData (..), - ConfirmedProposalState (..), HasUpdateConfiguration, - genesisBlockVersion, genesisSoftwareVersions, ourAppName) -import Pos.Core (HasConfiguration, ScriptVersion, SlotId (..)) -import Pos.Core.Configuration (genesisBlockVersionData, genesisHash) -import Pos.Core.Update (ApplicationName (..), BlockVersion (..), - BlockVersionModifier (..), NumSoftwareVersion, - SoftwareVersion (..), UpdateProposal (..)) -import Pos.DB.Update (getAdoptedBVFull, getConfirmedProposals, - getConfirmedSV) - -import Formatting (bprint, build, shown, (%)) -import qualified Formatting.Buildable -import Serokell.Data.Memory.Units (Byte) -import Serokell.Util (mapJson) - -import Cardano.Wallet.Kernel.NodeStateAdaptor (LockContext, - NodeConstraints, NodeStateAdaptor, WithNodeState, - mostRecentMainBlock, withNodeState) - -{------------------------------------------------------------------------------- - Chain state and state modifiers --------------------------------------------------------------------------------} - --- | Chain state --- --- This is an extract from a full chain state, containing only the variables --- that the wallet is interested in. -data ChainState = ChainState { - csBlockVersion :: !BlockVersion - , csSoftwareVersion :: !SoftwareVersion - , csScriptVersion :: !ScriptVersion - , csMaxTxSize :: !Byte - } - --- | Chain state modifier -data ChainStateModifier = ChainStateModifier { - csmBlockVersion :: !BlockVersion - , csmSoftwareVersion :: !SoftwareVersion - , csmScriptVersion :: !(Maybe ScriptVersion) - , csmMaxTxSize :: !(Maybe Byte) - } - --- | The header of the block the proposal got confirmed in and the corresponding --- 'ChainStateModifier' -fromCPS :: ConfirmedProposalState -> (HeaderHash, ChainStateModifier) -fromCPS ConfirmedProposalState{..} = (cpsConfirmed, ChainStateModifier { - csmBlockVersion = upBlockVersion - , csmSoftwareVersion = upSoftwareVersion - , csmScriptVersion = bvmScriptVersion - , csmMaxTxSize = bvmMaxTxSize - }) - where - UnsafeUpdateProposal{..} = cpsUpdateProposal - BlockVersionModifier{..} = upBlockVersionMod - --- | Apply a chain state modifier to a chain state -applyChainStateModifier :: ChainStateModifier -> ChainState -> ChainState -applyChainStateModifier ChainStateModifier{..} ChainState{..} = ChainState{ - csBlockVersion = csmBlockVersion - , csSoftwareVersion = csmSoftwareVersion - , csScriptVersion = fromMaybe csScriptVersion csmScriptVersion - , csMaxTxSize = fromMaybe csMaxTxSize csmMaxTxSize - } - -{------------------------------------------------------------------------------- - Chain summary --------------------------------------------------------------------------------} - --- | Self-consistent summary of the current tip of the chain -data ChainBrief = ChainBrief { - -- | Header hash of the chain tip, according to the node DB - cbTip :: !HeaderHash - - -- | Slot ID of the tip - -- - -- NOTE: This is /not/ the "current" slot ID, but rather the slot - -- associated with the 'cbTip'. The intention is that 'ChainBrief' - -- provides a consistent view of the node's database for restoration - -- purposes. If the current slot ID (based on timestamp) is needed, use - -- the 'MonadSlots' interface (but I strongly suspect 'MonadSlots' may in - -- fact only be needed by the underlying node). - , cbSlotId :: !SlotId - - -- | Header of the previous main block - -- - -- If there is no previous main block, this is set to the genesis hash. - , cbPrevMain :: !HeaderHash - - -- | The chain state at the time of 'cbTip' - -- - -- Implementation note: Although we have no way of verifying that these - -- actually match up, the hope is that since we read all these values - -- while locking the node state, that they will be consistent with each - -- other. That might be overly optimistic. - , cbState :: !ChainState - } - --- | Get 'ChainBrief' for current chain tip --- --- Returns --- --- * 'Nothing' if the current tip is the genesis block --- * The previous block if the current tip is an epoch boundary block (EBB) --- * The current block if the current tip is a regular block. -getChainBrief :: HasCallStack - => NodeStateAdaptor IO - -> LockContext - -> IO (Maybe ChainBrief) -getChainBrief node lc = withNodeState node $ \withLock -> do - (tip, (bv, bvd), sv) <- withLock lc $ \tip -> - (tip,,) - <$> getAdoptedBVFull - <*> getVersionOrThrow - - mMainBlock <- mostRecentMainBlock tip - case mMainBlock of - Nothing -> - return Nothing - Just mainBlock -> do - let slotId = mainBlock ^. mainBlockSlot - hdr = mainBlock ^. gbHeader - mPrevMain <- mostRecentMainBlock (hdr ^. prevBlockL) - return $ Just ChainBrief { - cbSlotId = slotId - , cbTip = headerHash hdr - , cbPrevMain = case mPrevMain of - Just prevMain -> headerHash prevMain - Nothing -> genesisHash - , cbState = ChainState { - csBlockVersion = bv - , csScriptVersion = bvdScriptVersion bvd - , csMaxTxSize = bvdMaxTxSize bvd - , csSoftwareVersion = sv - } - } - where - getVersionOrThrow :: NodeConstraints => WithNodeState IO SoftwareVersion - getVersionOrThrow = do - mSV <- getConfirmedSV ourAppName - case mSV of - Nothing -> throwM $ ChainStateMissingVersion callStack ourAppName - Just sv -> return $ SoftwareVersion ourAppName sv - --- | @a `chainBriefSucceeds` b@ is true when @a@ is the successor of @b@. -chainBriefSucceeds :: ChainBrief -> ChainBrief -> Bool -a `chainBriefSucceeds` b = cbPrevMain a == cbTip b - -{------------------------------------------------------------------------------- - Restoration --------------------------------------------------------------------------------} - -data ChainStateRestoration = ChainStateRestoration { - -- | Initial chain state - -- - -- This provides a base case for applying the 'ChainStateModifier's - csrGenesis :: !ChainState - - -- | All updates, indexed by the block in which they were confirmed - , csrUpdates :: !(Map HeaderHash ChainStateModifier) - - -- | Current chain state - -- - -- This provides the target for restoration, as well as its starting - -- point: we synchronously create a checkpoint for the current tip, and - -- then asynchronously restore the missing checkpoints (possibly from - -- genesis when we are restoring, or from another checkpoint if we are - -- catching up). - -- - -- If this field is 'Nothing', the chain does not contain any main blocks. - , csrCurrent :: !(Maybe ChainBrief) - } - --- | Get all information needed for restoration -getChainStateRestoration :: HasCallStack - => NodeStateAdaptor IO - -> LockContext - -> IO ChainStateRestoration -getChainStateRestoration node lc = do - current <- getChainBrief node lc - -- We don't need to lock now -- it's possible (in principle) that there - -- might be a new proposal at this point, but old proposals should still - -- exist. - -- - -- TODO: Unless this removes proposals that get rolled back...? - withNodeState node $ \_lock -> do - proposals <- getConfirmedProposals allVersions - sv <- case genesisSoftwareVersion of - Just sv -> return sv - Nothing -> throwM $ ChainStateMissingVersion callStack ourAppName - return ChainStateRestoration{ - csrGenesis = initChainState sv - , csrUpdates = Map.fromList $ map fromCPS proposals - , csrCurrent = current - } - where - -- We want all updates across all versions - allVersions :: Maybe NumSoftwareVersion - allVersions = Nothing - - -- Initial chain state (at the start of the blockchain) - -- - -- At the moment this gets determined by the configuration.yaml file - initChainState :: HasConfiguration => SoftwareVersion -> ChainState - initChainState sv = ChainState{ - csBlockVersion = genesisBlockVersion - , csSoftwareVersion = sv - , csScriptVersion = bvdScriptVersion - , csMaxTxSize = bvdMaxTxSize - } - where - BlockVersionData{..} = genesisBlockVersionData - - genesisSoftwareVersion :: HasUpdateConfiguration => Maybe SoftwareVersion - genesisSoftwareVersion = listToMaybe $ filter isOurs genesisSoftwareVersions - - isOurs :: HasUpdateConfiguration => SoftwareVersion -> Bool - isOurs sv = svAppName sv == ourAppName - -{------------------------------------------------------------------------------- - Custom exceptions --------------------------------------------------------------------------------} - -data ChainStateException = - ChainStateMissingVersion CallStack ApplicationName - deriving (Show) - -instance Exception ChainStateException - -{------------------------------------------------------------------------------- - Pretty printing --------------------------------------------------------------------------------} - -instance Buildable ChainState where - build ChainState{..} = bprint - ( "ChainState " - % "{ blockVersion: " % build - % ", softwareVersion: " % build - % ", scriptVersion: " % build - % ", maxTxSize: " % shown - % "}" - ) - csBlockVersion - csSoftwareVersion - csScriptVersion - csMaxTxSize - -instance Buildable ChainStateModifier where - build ChainStateModifier{..} = bprint - ( "ChainStateModifier " - % "{ blockVersion: " % build - % ", softwareVersion: " % build - % ", scriptVersion: " % build - % ", maxTxSize: " % shown - % "}" - ) - csmBlockVersion - csmSoftwareVersion - csmScriptVersion - csmMaxTxSize - -instance Buildable ChainStateRestoration where - build ChainStateRestoration{..} = bprint - ( "ChainStateRestoration " - % "{ genesis: " % build - % ", updates: " % mapJson - % ", current: " % build - % "}" - ) - csrGenesis - csrUpdates - csrCurrent - -instance Buildable ChainBrief where - build ChainBrief{..} = bprint - ( "ChainBrief " - % ", slotId: " % build - % ", tip: " % build - % ", state: " % build - % "}" - ) - cbSlotId - cbTip - cbState diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/AcidState.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/AcidState.hs index 08b716474f1..169ff1dbcfa 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/DB/AcidState.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/AcidState.hs @@ -16,9 +16,13 @@ module Cardano.Wallet.Kernel.DB.AcidState ( , CancelPending(..) , ApplyBlock(..) , SwitchToFork(..) + -- ** Restoration + , ApplyHistoricalBlock(..) + , RestorationComplete(..) -- ** Updates on HD wallets -- *** CREATE , CreateHdWallet(..) + , RestoreHdWallet(..) , CreateHdAccount(..) , CreateHdAddress(..) -- *** UPDATE @@ -37,7 +41,7 @@ module Cardano.Wallet.Kernel.DB.AcidState ( -- * Errors , NewPendingError(..) , NewForeignError(..) - , RollbackDuringRestoration(..) + , SwitchToForkError(..) ) where import Universum @@ -52,11 +56,11 @@ import qualified Formatting.Buildable import Test.QuickCheck (Arbitrary (..), oneof) import Pos.Chain.Txp (Utxo) -import Pos.Core (SlotId) -import Pos.Core.Chrono (OldestFirst (..)) +import Pos.Core.Chrono (NewestFirst, OldestFirst (..)) import Pos.Core.Txp (TxAux, TxId) import Pos.Core.Update (SoftwareVersion) +import Cardano.Wallet.Kernel.DB.BlockContext import Cardano.Wallet.Kernel.DB.HdWallet import qualified Cardano.Wallet.Kernel.DB.HdWallet.Create as HD import qualified Cardano.Wallet.Kernel.DB.HdWallet.Delete as HD @@ -70,10 +74,11 @@ import qualified Cardano.Wallet.Kernel.DB.Updates as Updates import Cardano.Wallet.Kernel.DB.Util.AcidState import Cardano.Wallet.Kernel.DB.Util.IxSet (IxSet) import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet -import Cardano.Wallet.Kernel.NodeStateAdaptor (SecurityParameter) +import Cardano.Wallet.Kernel.NodeStateAdaptor (SecurityParameter (..)) import Cardano.Wallet.Kernel.PrefilterTx (AddrWithId, PrefilteredBlock (..), emptyPrefilteredBlock) import Cardano.Wallet.Kernel.Util (markMissingMapEntries) +import Cardano.Wallet.Kernel.Util.StrictNonEmpty (StrictNonEmpty) {------------------------------------------------------------------------------- Top-level database @@ -125,12 +130,17 @@ data NewForeignError = -- | Some inputs are not in the wallet utxo | NewForeignFailed Spec.NewForeignFailed --- | We cannot roll back when we don't have full historical data available -data RollbackDuringRestoration = RollbackDuringRestoration +-- | Errors thrown by 'SwitchToFork' +data SwitchToForkError = + -- | We cannot roll back when we don't have full historical data available + RollbackDuringRestoration + + -- | Apply block failed + | ApplyBlockFailed Spec.ApplyBlockFailed deriveSafeCopy 1 'base ''NewPendingError deriveSafeCopy 1 'base ''NewForeignError -deriveSafeCopy 1 'base ''RollbackDuringRestoration +deriveSafeCopy 1 'base ''SwitchToForkError {------------------------------------------------------------------------------- Wrap wallet spec @@ -221,13 +231,14 @@ cancelPending cancelled = void . runUpdate' . zoom dbHdWallets $ -- empty/. This is important because for blocks that don't change we still -- need to push a new checkpoint. applyBlock :: SecurityParameter - -> InDb SlotId + -> BlockContext -> Map HdAccountId PrefilteredBlock - -> Update DB (Map HdAccountId (Set TxId)) -applyBlock k (InDb slotId) blocks = runUpdateNoErrors $ zoom dbHdWallets $ + -> Update DB (Either Spec.ApplyBlockFailed (Map HdAccountId (Set TxId))) +applyBlock k context blocks = runUpdateDiscardSnapshot $ zoom dbHdWallets $ updateAccounts =<< mkUpdates <$> use hdWalletsAccounts where - mkUpdates :: IxSet HdAccount -> [AccountUpdate Void (Set TxId)] + mkUpdates :: IxSet HdAccount + -> [AccountUpdate Spec.ApplyBlockFailed (Set TxId)] mkUpdates existingAccounts = map mkUpdate . Map.toList @@ -244,19 +255,99 @@ applyBlock k (InDb slotId) blocks = runUpdateNoErrors $ zoom dbHdWallets $ -- initial utxo for accounts discovered during 'applyBlock' (and -- 'switchToFork') mkUpdate :: (HdAccountId, Maybe PrefilteredBlock) - -> AccountUpdate Void (Set TxId) + -> AccountUpdate Spec.ApplyBlockFailed (Set TxId) mkUpdate (accId, mPB) = AccountUpdate { accountUpdateId = accId , accountUpdateAddrs = pfbAddrs pb - , accountUpdateNew = AccountUpdateNew Map.empty + , accountUpdateNew = AccountUpdateNewUpToDate Map.empty , accountUpdate = matchHdAccountCheckpoints - (state $ swap . Spec.applyBlock k slotId pb) - (state $ swap . Spec.applyBlockPartial k slotId pb) + (Spec.applyBlock k pb) + (Spec.applyBlockPartial pb) + } + where + pb :: PrefilteredBlock + pb = fromMaybe (emptyPrefilteredBlock context) mPB + +-- | Apply a block, as in 'applyBlock', but on the historical +-- checkpoints of an account rather than the current checkpoints. +applyHistoricalBlock :: SecurityParameter + -> BlockContext + -> Map HdAccountId PrefilteredBlock + -> Update DB (Either Spec.ApplyBlockFailed ()) +applyHistoricalBlock k context blocks = + runUpdateDiscardSnapshot $ zoom dbHdWallets $ + updateAccounts_ =<< mkUpdates <$> use hdWalletsAccounts + where + mkUpdates :: IxSet HdAccount -> [AccountUpdate Spec.ApplyBlockFailed ()] + mkUpdates existingAccounts = + map mkUpdate + . Map.toList + . markMissingMapEntries (IxSet.toMap existingAccounts) + $ blocks + + -- The account update + -- + -- /If/ we discover an account while we apply the block, that account + -- must definitely be in incomplete state; its initial checkpoint will + -- have an empty genesis UTxO and an empty current UTxO. (It can't have + -- a non-empty genesis UTxO because if it did we would already have + -- known about this account). + mkUpdate :: (HdAccountId, Maybe PrefilteredBlock) + -> AccountUpdate Spec.ApplyBlockFailed () + mkUpdate (accId, mPB) = AccountUpdate { + accountUpdateId = accId + , accountUpdateAddrs = pfbAddrs pb + , accountUpdateNew = AccountUpdateNewIncomplete mempty mempty + , accountUpdate = void $ withZoom $ \acc zoomTo -> do + -- Under normal circumstances we should not encounter an account + -- that is in UpToDate state during restoration. There is only one + -- circumstance under which this can happen: we start restoration, + -- and now during a regular call to 'applyBlock' (not + -- 'applyBlockHistorical') we discover a new account. Since + -- 'applyBlock' is not aware that we are restoring, it will create a + -- new account in up-to-date state. If this happens, we rectify the + -- situation here. + let updateHistory :: NewestFirst StrictNonEmpty PartialCheckpoint + -> NewestFirst StrictNonEmpty Checkpoint + -> HdAccount + updateHistory current history' = + acc & hdAccountState .~ HdAccountStateIncomplete + (HdAccountIncomplete { + _hdIncompleteCurrent = current + , _hdIncompleteHistorical = history' + }) + case acc ^. hdAccountState of + HdAccountStateUpToDate (HdAccountUpToDate upToDate) -> do + let current = fmap (view fromFullCheckpoint) upToDate + history = one $ initCheckpoint mempty + zoomTo history (updateHistory current) $ Spec.applyBlock k pb + HdAccountStateIncomplete (HdAccountIncomplete current history) -> + zoomTo history (updateHistory current) $ Spec.applyBlock k pb } where pb :: PrefilteredBlock - pb = fromMaybe emptyPrefilteredBlock mPB + pb = fromMaybe (emptyPrefilteredBlock context) mPB + +-- | Finish restoration of a wallet +-- +-- When the restoration thread has completed its work, it should call this +-- function to mark all accounts as up to date +restorationComplete :: SecurityParameter -> HdRootId -> Update DB () +restorationComplete k rootId = runUpdateNoErrors $ zoom dbHdWallets $ + zoomAll_ hdWalletsAccounts $ + modify $ \acc -> go acc (acc ^. hdAccountState) + where + go :: HdAccount -> HdAccountState -> HdAccount + go acc (HdAccountStateUpToDate _) = acc + go acc (HdAccountStateIncomplete st) + | accRootId acc /= rootId = acc + | otherwise = + let st' = finishRestoration k st + in acc & hdAccountState .~ (HdAccountStateUpToDate st') + + accRootId :: HdAccount -> HdRootId + accRootId = view (hdAccountId . hdAccountIdParent) -- | Switch to a fork -- @@ -270,14 +361,14 @@ applyBlock k (InDb slotId) blocks = runUpdateNoErrors $ zoom dbHdWallets $ -- does not have a 'SafeCopy' instance. switchToFork :: SecurityParameter -> Int - -> [(SlotId, Map HdAccountId PrefilteredBlock)] - -> Update DB (Either RollbackDuringRestoration + -> [(BlockContext, Map HdAccountId PrefilteredBlock)] + -> Update DB (Either SwitchToForkError (Map HdAccountId (Pending, Set TxId))) switchToFork k n blocks = runUpdateDiscardSnapshot $ zoom dbHdWallets $ updateAccounts =<< mkUpdates <$> use hdWalletsAccounts where mkUpdates :: IxSet HdAccount - -> [AccountUpdate RollbackDuringRestoration (Pending, Set TxId)] + -> [AccountUpdate SwitchToForkError (Pending, Set TxId)] mkUpdates existingAccounts = map mkUpdate . Map.toList @@ -285,20 +376,17 @@ switchToFork k n blocks = runUpdateDiscardSnapshot $ zoom dbHdWallets $ . map (second (markMissingMapEntries (IxSet.toMap existingAccounts))) $ blocks - mkUpdate :: (HdAccountId, [(SlotId, Maybe PrefilteredBlock)]) - -> AccountUpdate RollbackDuringRestoration (Pending, Set TxId) - mkUpdate (accId, mPBs) = AccountUpdate { + mkUpdate :: (HdAccountId, OldestFirst [] PrefilteredBlock) + -> AccountUpdate SwitchToForkError (Pending, Set TxId) + mkUpdate (accId, pbs) = AccountUpdate { accountUpdateId = accId - , accountUpdateAddrs = concatMap (pfbAddrs . snd) pbs - , accountUpdateNew = AccountUpdateNew Map.empty + , accountUpdateAddrs = concatMap pfbAddrs pbs + , accountUpdateNew = AccountUpdateNewUpToDate Map.empty , accountUpdate = matchHdAccountCheckpoints - (state $ swap . Spec.switchToFork k n (OldestFirst pbs)) + (mapUpdateErrors ApplyBlockFailed $ Spec.switchToFork k n pbs) (throwError RollbackDuringRestoration) } - where - pbs :: [(SlotId, PrefilteredBlock)] - pbs = map (second (fromMaybe emptyPrefilteredBlock)) mPBs -- The natural result of prefiltering each block is a list of maps, but -- in order to apply them to each account, we want a map of lists @@ -307,36 +395,40 @@ switchToFork k n blocks = runUpdateDiscardSnapshot $ zoom dbHdWallets $ -- make sure that if, say, the first and third slot both contain a block for -- account A, but the second does not, we end up with an empty block -- inserted for slot 2. - redistribute :: [(SlotId, Map HdAccountId (Maybe PrefilteredBlock))] - -> Map HdAccountId [(SlotId, Maybe PrefilteredBlock)] - redistribute = Map.map (sortBy (comparing fst)) + redistribute :: [(BlockContext, Map HdAccountId (Maybe PrefilteredBlock))] + -> Map HdAccountId (OldestFirst [] PrefilteredBlock) + redistribute = Map.map mkPBS . Map.unionsWith (++) . map (\(slotId, pbs) -> Map.map (\pb -> [(slotId, pb)]) pbs) + mkPBS :: [(BlockContext, Maybe PrefilteredBlock)] + -> OldestFirst [] PrefilteredBlock + mkPBS = OldestFirst + . map (\(bc, mPB) -> fromMaybe (emptyPrefilteredBlock bc) mPB) + . sortBy (comparing (view bcSlotId . fst)) + -- | Observable rollback, used for tests only -- -- Returns the set of pending transactions that have become pending again, -- for each account. -- See 'switchToFork' for use in real code. -observableRollbackUseInTestsOnly :: Update DB (Either RollbackDuringRestoration +observableRollbackUseInTestsOnly :: Update DB (Either SwitchToForkError (Map HdAccountId Pending)) observableRollbackUseInTestsOnly = runUpdateDiscardSnapshot $ zoomAll (dbHdWallets . hdWalletsAccounts) $ matchHdAccountCheckpoints - (state $ swap . Spec.observableRollbackUseInTestsOnly) + (Spec.observableRollbackUseInTestsOnly) (throwError RollbackDuringRestoration) {------------------------------------------------------------------------------- Wallet creation -------------------------------------------------------------------------------} --- | Create an HdWallet with HdRoot, possibly with HdAccounts and HdAddresses. --- --- Given prefiltered utxo's, by account, create an HdAccount for each account, --- along with HdAddresses for all utxo outputs. +-- | Create an HdWallet with HdRoot -- --- NOTE: since the genesis Utxo does not come into being through regular --- transactions, there is no block metadata to record when we create a wallet. +-- NOTE: We allow an initial set of accounts with associated addresses and +-- balances /ONLY/ for testing purpose. Normally this should be empty; see +-- 'createHdWallet'/'createWalletHdRnd' in "Cardano.Wallet.Kernel.Wallets". createHdWallet :: HdRoot -> Map HdAccountId (Utxo,[AddrWithId]) -> Update DB (Either HD.CreateHdRootError ()) @@ -349,11 +441,31 @@ createHdWallet newRoot utxoByAccount = -> AccountUpdate HD.CreateHdRootError () mkUpdate (accId, (utxo, addrs)) = AccountUpdate { accountUpdateId = accId - , accountUpdateNew = AccountUpdateNew utxo + , accountUpdateNew = AccountUpdateNewUpToDate utxo , accountUpdateAddrs = addrs , accountUpdate = return () -- just need to create it, no more } +-- | Begin restoration by creating an HdWallet with the given HdRoot, +-- starting from the 'HdAccountOutsideK' state. +restoreHdWallet :: HdRoot + -> Map HdAccountId (Utxo, Utxo, [AddrWithId]) + -- ^ Current and genesis UTxO per account + -> Update DB (Either HD.CreateHdRootError ()) +restoreHdWallet newRoot utxoByAccount = + runUpdateDiscardSnapshot . zoom dbHdWallets $ do + HD.createHdRoot newRoot + updateAccounts_ $ map mkUpdate (Map.toList utxoByAccount) + where + mkUpdate :: (HdAccountId, (Utxo, Utxo, [AddrWithId])) + -> AccountUpdate HD.CreateHdRootError () + mkUpdate (accId, (curUtxo, genUtxo, addrs)) = AccountUpdate { + accountUpdateId = accId + , accountUpdateNew = AccountUpdateNewIncomplete curUtxo genUtxo + , accountUpdateAddrs = addrs + , accountUpdate = return () -- Create it only + } + {------------------------------------------------------------------------------- Internal: support for updating accounts -------------------------------------------------------------------------------} @@ -387,18 +499,45 @@ data AccountUpdate e a = AccountUpdate { -- so this is what we use for the 'SlotId' of the first account. -- -- See 'AccountUpdate'. -data AccountUpdateNew = AccountUpdateNew { - -- | 'UTxO' to use to create the first checkpoint - accountUpdateUtxo :: !Utxo - } +data AccountUpdateNew = + -- | Create new account which is up to date with the blockchain + -- + -- Conceptually the first checkpoint of new account is always created in + -- slot 0 of epoch 0, at the dawn of time, and this is what we use for + -- the 'SlotId'. We nonetheless allow to specify a 'Utxo' for this + -- checkpoint, since some accounts are assigned an initial balance + -- in the Cardano genesis block. + -- + -- NOTE: The /ONLY/ reason that we allow for an initial UTxO is here + -- is that for testing purposes it is convenient to be able to create + -- a wallet with an initial non-empty UTxO. + AccountUpdateNewUpToDate !Utxo + + -- | Create a new account which will be in restoration state + -- + -- We specify + -- + -- * The current UTxO (obtained by filtering the full node's current UTxO) + -- * The genesis UTxO (obtained by filtering 'genesisUtxo') + | AccountUpdateNewIncomplete !Utxo !Utxo -- | Brand new account (if one needs to be created) accountUpdateCreate :: HdAccountId -> AccountUpdateNew -> HdAccount -accountUpdateCreate accId AccountUpdateNew{..} = - HD.initHdAccount accId firstCheckpoint +accountUpdateCreate accId (AccountUpdateNewUpToDate utxo) = + HD.initHdAccount accId initState where - firstCheckpoint :: Checkpoint - firstCheckpoint = initCheckpoint accountUpdateUtxo + initState :: HdAccountState + initState = HdAccountStateUpToDate HdAccountUpToDate { + _hdUpToDateCheckpoints = one $ initCheckpoint utxo + } +accountUpdateCreate accId (AccountUpdateNewIncomplete curUtxo genUtxo) = + HD.initHdAccount accId initState + where + initState :: HdAccountState + initState = HdAccountStateIncomplete HdAccountIncomplete { + _hdIncompleteCurrent = one $ initPartialCheckpoint curUtxo + , _hdIncompleteHistorical = one $ initCheckpoint genUtxo + } updateAccount :: AccountUpdate e a -> Update' HdWallets e (HdAccountId, a) updateAccount AccountUpdate{..} = do @@ -415,7 +554,7 @@ updateAccount AccountUpdate{..} = do createAddress (addressId, address) = zoomOrCreateHdAddress assumeHdAccountExists -- we just created it - (HD.initHdAddress addressId (InDb address)) + (HD.initHdAddress addressId address) addressId (return ()) @@ -507,6 +646,8 @@ makeAcidic ''DB [ , 'cancelPending , 'applyBlock , 'switchToFork + , 'applyHistoricalBlock + , 'restorationComplete -- Updates on HD wallets , 'createHdRoot , 'createHdAddress @@ -517,6 +658,7 @@ makeAcidic ''DB [ , 'updateHdAccountName , 'deleteHdRoot , 'deleteHdAccount + , 'restoreHdWallet -- Software updates , 'addUpdate , 'removeNextUpdate diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/BlockContext.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/BlockContext.hs new file mode 100644 index 00000000000..4062423e57a --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/BlockContext.hs @@ -0,0 +1,91 @@ +module Cardano.Wallet.Kernel.DB.BlockContext ( + -- * Block context + BlockContext(..) + , blockContextSucceeds + -- ** Lenses + , bcSlotId + , bcHash + , bcPrevMain + -- * Construction + , mainBlockContext + ) where + +import Universum + +import Control.Lens (makeLenses) +import Data.SafeCopy (base, deriveSafeCopy) +import Formatting (bprint, build, (%)) +import qualified Formatting.Buildable + +import qualified Pos.Chain.Block as Core +import qualified Pos.Core as Core + +import Cardano.Wallet.Kernel.DB.InDb +import Cardano.Wallet.Kernel.NodeStateAdaptor + +{------------------------------------------------------------------------------- + Block context +-------------------------------------------------------------------------------} + +-- | Information about where a block is placed in the chain +data BlockContext = BlockContext { + -- | Slot ID of this block + _bcSlotId :: !(InDb Core.SlotId) + + -- | Header hash of this block + , _bcHash :: !(InDb Core.HeaderHash) + + -- | Header hash of the previous /main/ block + -- + -- NOTE: Since this is used in 'applyBlock' to check whether or not + -- this block fits onto the chain, and we only apply main blocks, + -- it is important that if the raw block's previous pointer to an EBB, + -- we do some work to figure out what the previous /main/ block was. + -- See 'mostRecentMainBlock'. + , _bcPrevMain :: !(Maybe (InDb Core.HeaderHash)) + } + +makeLenses ''BlockContext +deriveSafeCopy 1 'base ''BlockContext + +-- | Check if one checkpoint succeeds another +-- +-- The second argument is a 'Maybe', because the first checkpoint in an account +-- will have no context. The first argument is /not/ a 'Maybe' because /ONLY/ +-- the first checkpoint in an account can have no context. +blockContextSucceeds :: BlockContext -> Maybe BlockContext -> Bool +_ `blockContextSucceeds` Nothing = True +a `blockContextSucceeds` (Just b) = + case a ^. bcPrevMain of + Nothing -> False -- Previous checkpoint must have been the initial one + Just prev -> prev == b ^. bcHash + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +mainBlockContext :: (NodeConstraints, MonadIO m, MonadCatch m) + => Core.MainBlock -> WithNodeState m BlockContext +mainBlockContext mb = do + mPrev <- mostRecentMainBlock (mb ^. Core.mainBlockPrevBlock) + return BlockContext { + _bcSlotId = InDb $ mb ^. Core.mainBlockSlot + , _bcHash = InDb $ Core.headerHash mb + , _bcPrevMain = (InDb . Core.headerHash) <$> mPrev + } + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance Buildable BlockContext where + build BlockContext{..} = bprint + ( "BlockContext " + % "{ slotId " % build + % ", hash " % build + % ", prev " % build + % "}" + ) + _bcSlotId + _bcHash + _bcPrevMain diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/BlockMeta.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/BlockMeta.hs index efee9e07a11..e700e211776 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/DB/BlockMeta.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/BlockMeta.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} -- | Block metadata conform the wallet specification module Cardano.Wallet.Kernel.DB.BlockMeta ( @@ -162,3 +164,5 @@ instance Buildable BlockMeta where ) (_fromDb _blockMetaSlotId) _blockMetaAddressMeta + +deriving instance Buildable LocalBlockMeta diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet.hs index 8bc80e31c77..c437c95b4a7 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet.hs @@ -23,9 +23,7 @@ module Cardano.Wallet.Kernel.DB.HdWallet ( -- * HD Wallet state , HdAccountState(..) , HdAccountUpToDate(..) - , HdAccountWithinK(..) - , HdAccountOutsideK(..) - , reachedWithinK + , HdAccountIncomplete(..) , finishRestoration -- ** Initialiser , initHdWallets @@ -54,12 +52,9 @@ module Cardano.Wallet.Kernel.DB.HdWallet ( , hdAccountStateCurrent -- *** Account state: up to date , hdUpToDateCheckpoints - -- *** Account state: within K slots - , hdWithinKCurrent - , hdWithinKHistorical - -- *** Account state: outside K slots - , hdOutsideKCurrent - , hdOutsideKHistorical + -- *** Account state: under restoration + , hdIncompleteCurrent + , hdIncompleteHistorical -- *** Address , hdAddressId , hdAddressAddress @@ -104,18 +99,22 @@ import Test.QuickCheck (Arbitrary (..), oneof, vectorOf) import Formatting (bprint, build, (%)) import qualified Formatting.Buildable +import Serokell.Util (listJson) import qualified Pos.Core as Core import Pos.Core.Chrono (NewestFirst (..)) import qualified Pos.Crypto as Core import Cardano.Wallet.API.V1.Types (V1 (..)) +import Cardano.Wallet.Kernel.DB.BlockContext import Cardano.Wallet.Kernel.DB.InDb import Cardano.Wallet.Kernel.DB.Spec import Cardano.Wallet.Kernel.DB.Util.AcidState import Cardano.Wallet.Kernel.DB.Util.IxSet import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet hiding (Indexable) -import Cardano.Wallet.Kernel.Util (modifyAndGetOld) +import Cardano.Wallet.Kernel.NodeStateAdaptor (SecurityParameter (..)) +import Cardano.Wallet.Kernel.Util (liftNewestFirst, modifyAndGetOld) +import qualified Cardano.Wallet.Kernel.Util.StrictList as SL import Cardano.Wallet.Kernel.Util.StrictNonEmpty (StrictNonEmpty (..)) import qualified Cardano.Wallet.Kernel.Util.StrictNonEmpty as SNE @@ -317,80 +316,80 @@ data HdAddress = HdAddress { -- | Account state (essentially, how much historical data do we have?) data HdAccountState = - HdAccountStateUpToDate !HdAccountUpToDate - | HdAccountStateWithinK !HdAccountWithinK - | HdAccountStateOutsideK !HdAccountOutsideK + HdAccountStateUpToDate !HdAccountUpToDate + | HdAccountStateIncomplete !HdAccountIncomplete -- | Account state for an account which has complete historical data data HdAccountUpToDate = HdAccountUpToDate { _hdUpToDateCheckpoints :: !(NewestFirst StrictNonEmpty Checkpoint) } --- | Account state for an account which is lacking some historical checkpoints, --- but is within k slots of the tip. --- --- NOTE: If the wallet backend gets shut down during restoration, and later --- restarted, it cannot be the case that the wallet is behind the full node, --- since the full node /itself/ will also be behind the chain. The wallet can --- /only/ be behind the full node if a wallet (that already exists on the chain) --- gets added to a running full node. -data HdAccountWithinK = HdAccountWithinK { +-- | Account state for an account which is lacking some historical checkpoints +-- (which is currently being restored) +data HdAccountIncomplete = HdAccountIncomplete { -- | Current checkpoints -- -- During wallet restoration we always track the underlying node, but may -- lack historical checkpoints. We synchronously construct a partial -- checkpoint for the current tip, and then as we get new blocks from -- the BListener, we add new partial checkpoints. - _hdWithinKCurrent :: !(NewestFirst StrictNonEmpty PartialCheckpoint) + _hdIncompleteCurrent :: !(NewestFirst StrictNonEmpty PartialCheckpoint) -- | Historical full checkpoints -- -- Meanwhile, we asynchronously construct full checkpoints, starting -- from genesis. Once this gets to within k slots of the tip, we start -- keeping all of these. - , _hdWithinKHistorical :: !(NewestFirst StrictNonEmpty Checkpoint) - } - --- | Account state for an account which is lacking historical checkpoints, --- and hasn't reached the block that is within k slots of the tip yet. -data HdAccountOutsideK = HdAccountOutsideK { - -- | Current checkpoint - _hdOutsideKCurrent :: !(NewestFirst StrictNonEmpty PartialCheckpoint) - - -- | Historical full checkpoints - -- - -- Since we haven't reached the block k away yet, we only need to - -- keep this one checkpoint. - , _hdOutsideKHistorical :: !Checkpoint + , _hdIncompleteHistorical :: !(NewestFirst StrictNonEmpty Checkpoint) } makeLenses ''HdAccountUpToDate -makeLenses ''HdAccountWithinK -makeLenses ''HdAccountOutsideK - --- | Once we reached K slots from the tip, we should start collecting --- checkpoints rather than just keeping the most recent. -reachedWithinK :: HdAccountOutsideK -> HdAccountWithinK -reachedWithinK HdAccountOutsideK{..} = HdAccountWithinK{ - _hdWithinKCurrent = _hdOutsideKCurrent - , _hdWithinKHistorical = NewestFirst $ SNE.singleton _hdOutsideKHistorical - } +makeLenses ''HdAccountIncomplete -- | Restoration is complete when we have all historical checkpoints -- --- NOTE: The local block metadata in the partial checkpoints /already/ --- accumulates (the local block metadata in the next partial checkpoint includes --- the local block metadata in the previous). Therefore we get the most recent --- /full/ checkpoint, and use that as the basis for constructing full block --- metadata for /all/ partial checkpoints. -finishRestoration :: HdAccountWithinK -> HdAccountUpToDate -finishRestoration HdAccountWithinK{..} = HdAccountUpToDate{ - _hdUpToDateCheckpoints = - map (toFullCheckpoint mostRecent) _hdWithinKCurrent - <> _hdWithinKHistorical - } +-- NOTE: +-- +-- * The local block metadata in the partial checkpoints /already/ +-- accumulates (the local block metadata in the next partial checkpoint +-- includes the local block metadata in the previous). Therefore we get the +-- most recent /full/ checkpoint, and use that as the basis for constructing +-- full block metadata for /all/ partial checkpoints. +-- +-- * We do NOT use the oldest partial checkpoint, since it will have its +-- UTxO set from the underlying node's UTxO rather than from a block, and +-- will therefore not have valid block metadata associated with it. +-- (It is also possible that the initial checkpoint was created later, with +-- an empty UTxO, if we discover it /during/ restoration). +-- +-- * We verify that the second-oldest partial checkpoint's previous pointer (if +-- one exists) lines up with the most recent historical checkpoint. +finishRestoration :: SecurityParameter + -> HdAccountIncomplete + -> HdAccountUpToDate +finishRestoration (SecurityParameter k) (HdAccountIncomplete partial historical) = + case SL.last initPartial of + Nothing -> + HdAccountUpToDate $ takeNewest k $ NewestFirst $ + (mostRecentHistorical :| olderHistorical) + Just secondLast | Just context <- secondLast ^. pcheckpointContext -> + if context `blockContextSucceeds` (mostRecentHistorical ^. checkpointContext) + then HdAccountUpToDate $ takeNewest k $ NewestFirst $ + SNE.prependList + (mkFull <$> initPartial) + (mostRecentHistorical :| olderHistorical) + else error "finishRestoration: checkpoints do not line up!" + _otherwise -> + error "finishRestoration: invalid partial checkpoint (missing context)" where - NewestFirst (mostRecent :| _) = _hdWithinKHistorical + (initPartial, _oldestPartial) = SNE.splitLast $ getNewestFirst partial + mostRecentHistorical :| olderHistorical = getNewestFirst historical + + mkFull :: PartialCheckpoint -> Checkpoint + mkFull = toFullCheckpoint (mostRecentHistorical ^. checkpointBlockMeta) + + takeNewest :: Int -> NewestFirst StrictNonEmpty a -> NewestFirst StrictNonEmpty a + takeNewest = liftNewestFirst . SNE.take {------------------------------------------------------------------------------- Template Haskell splices @@ -413,8 +412,7 @@ deriveSafeCopy 1 'base ''HdAddress deriveSafeCopy 1 'base ''HdAccountState deriveSafeCopy 1 'base ''HdAccountUpToDate -deriveSafeCopy 1 'base ''HdAccountWithinK -deriveSafeCopy 1 'base ''HdAccountOutsideK +deriveSafeCopy 1 'base ''HdAccountIncomplete {------------------------------------------------------------------------------- Derived lenses @@ -435,16 +433,11 @@ hdAccountStateCurrent f (HdAccountStateUpToDate st) = where l :: Lens' HdAccountUpToDate PartialCheckpoint l = hdUpToDateCheckpoints . _Wrapped . SNE.head . fromFullCheckpoint -hdAccountStateCurrent f (HdAccountStateWithinK st) = - (\pcp -> HdAccountStateWithinK (st & l .~ pcp)) <$> f (st ^. l) - where - l :: Lens' HdAccountWithinK PartialCheckpoint - l = hdWithinKCurrent . _Wrapped . SNE.head -hdAccountStateCurrent f (HdAccountStateOutsideK st) = - (\pcp -> HdAccountStateOutsideK (st & l .~ pcp)) <$> f (st ^. l) +hdAccountStateCurrent f (HdAccountStateIncomplete st) = + (\pcp -> HdAccountStateIncomplete (st & l .~ pcp)) <$> f (st ^. l) where - l :: Lens' HdAccountOutsideK PartialCheckpoint - l = hdOutsideKCurrent . _Wrapped . SNE.head + l :: Lens' HdAccountIncomplete PartialCheckpoint + l = hdIncompleteCurrent . _Wrapped . SNE.head {------------------------------------------------------------------------------- Unknown identifiers @@ -628,29 +621,22 @@ zoomHdCardanoAddress embedErr addr = -- | Pattern match on the state of the account matchHdAccountState :: CanZoom f - => f HdAccountUpToDate e a - -> f HdAccountWithinK e a - -> f HdAccountOutsideK e a - -> f HdAccount e a -matchHdAccountState updUpToDate updWithinK updOutsideK = withZoom $ \acc zoomTo -> + => f HdAccountUpToDate e a + -> f HdAccountIncomplete e a + -> f HdAccount e a +matchHdAccountState updUpToDate updIncomplete = withZoom $ \acc zoomTo -> case acc ^. hdAccountState of HdAccountStateUpToDate st -> - zoomTo st (\st' -> acc & hdAccountState .~ HdAccountStateUpToDate st') updUpToDate - HdAccountStateWithinK st -> - zoomTo st (\st' -> acc & hdAccountState .~ HdAccountStateWithinK st') updWithinK - HdAccountStateOutsideK st -> - zoomTo st (\st' -> acc & hdAccountState .~ HdAccountStateOutsideK st') updOutsideK + zoomTo st (\st' -> acc & hdAccountState .~ HdAccountStateUpToDate st') updUpToDate + HdAccountStateIncomplete st -> + zoomTo st (\st' -> acc & hdAccountState .~ HdAccountStateIncomplete st') updIncomplete -- | Zoom to the current checkpoints of the wallet zoomHdAccountCheckpoints :: CanZoom f => ( forall c. IsCheckpoint c => f (NewestFirst StrictNonEmpty c) e a ) -> f HdAccount e a -zoomHdAccountCheckpoints upd = - matchHdAccountState - (zoom hdUpToDateCheckpoints upd) - (zoom hdWithinKCurrent upd) - (zoom hdOutsideKCurrent upd) +zoomHdAccountCheckpoints upd = matchHdAccountCheckpoints upd upd -- | Zoom to the most recent checkpoint zoomHdAccountCurrent :: CanZoom f @@ -673,8 +659,7 @@ matchHdAccountCheckpoints :: CanZoom f matchHdAccountCheckpoints updFull updPartial = matchHdAccountState (zoom hdUpToDateCheckpoints updFull) - (zoom hdWithinKCurrent updPartial) - (zoom hdOutsideKCurrent updPartial) + (zoom hdIncompleteCurrent updPartial) {------------------------------------------------------------------------------- Zoom to parts of the wallet, creating them if they don't exist @@ -788,9 +773,28 @@ instance Buildable HdAccount where _hdAccountAutoPkCounter instance Buildable HdAccountState where - build (HdAccountStateUpToDate _cps) = "HdAccountStateUpToDate " - build (HdAccountStateWithinK _cps) = "HdAccountStateWithinK " - build (HdAccountStateOutsideK _cps) = "HdAccountStateOutsideK " + build (HdAccountStateUpToDate st) = + bprint ("HdAccountStateUpToDate " % build) st + build (HdAccountStateIncomplete st) = + bprint ("HdAccountStateIncomplete " % build) st + +instance Buildable HdAccountUpToDate where + build HdAccountUpToDate{..} = bprint + ( "HdAccountUpToDate " + % "{ checkpoints: " % listJson + % "}" + ) + _hdUpToDateCheckpoints + +instance Buildable HdAccountIncomplete where + build HdAccountIncomplete{..} = bprint + ( "HdAccountIncomplete " + % "{ current: " % listJson + % ", historical: " % listJson + % "}" + ) + _hdIncompleteCurrent + _hdIncompleteHistorical instance Buildable HdAddress where build HdAddress{..} = bprint diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Create.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Create.hs index 78be4ec965e..bd269d38bba 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Create.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Create.hs @@ -25,16 +25,13 @@ import Formatting (bprint, build, sformat, (%)) import qualified Formatting.Buildable import qualified Pos.Core as Core -import Pos.Core.Chrono import Cardano.Wallet.Kernel.DB.HdWallet import Cardano.Wallet.Kernel.DB.InDb -import Cardano.Wallet.Kernel.DB.Spec import Cardano.Wallet.Kernel.DB.Util.AcidState import Cardano.Wallet.Kernel.DB.Util.IxSet (AutoIncrementKey (..), Indexed (..)) import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet -import qualified Cardano.Wallet.Kernel.Util.StrictNonEmpty as SNE {------------------------------------------------------------------------------- Errors @@ -150,15 +147,12 @@ initHdRoot rootId name hasPass assurance created = HdRoot { -- It is the responsibility of the caller to check the wallet's spending -- password. initHdAccount :: HdAccountId - -> Checkpoint + -> HdAccountState -> HdAccount -initHdAccount accountId checkpoint = HdAccount { +initHdAccount accountId st = HdAccount { _hdAccountId = accountId , _hdAccountName = defName - , _hdAccountState = HdAccountStateUpToDate - $ HdAccountUpToDate - $ NewestFirst - $ SNE.singleton checkpoint + , _hdAccountState = st , _hdAccountAutoPkCounter = AutoIncrementKey 0 } where @@ -175,11 +169,11 @@ initHdAccount accountId checkpoint = HdAccount { -- Similarly, it will be the responsibility of the caller to pick a random -- address index, as we do not have access to a random number generator here. initHdAddress :: HdAddressId - -> InDb Core.Address + -> Core.Address -> HdAddress initHdAddress addrId address = HdAddress { _hdAddressId = addrId - , _hdAddressAddress = address + , _hdAddressAddress = InDb address } {------------------------------------------------------------------------------- diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/Resolved.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/Resolved.hs index cf0d704ffe2..a89281b0616 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/DB/Resolved.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/Resolved.hs @@ -11,7 +11,7 @@ module Cardano.Wallet.Kernel.DB.Resolved ( , rtxOutputs , rtxMeta , rbTxs - , rbSlotId + , rbContext , rbMeta ) where @@ -21,13 +21,14 @@ import Control.Lens.TH (makeLenses) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Formatting (bprint, (%)) -import Formatting.Buildable +import qualified Formatting.Buildable import Serokell.Util (listJson, mapJson, pairF) import qualified Pos.Chain.Txp as Core -import Pos.Core (Coin, SlotId, Timestamp) +import Pos.Core (Coin, Timestamp) +import Cardano.Wallet.Kernel.DB.BlockContext import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD import Cardano.Wallet.Kernel.DB.InDb import Cardano.Wallet.Kernel.DB.TxMeta.Types @@ -97,13 +98,13 @@ resolvedToTxMeta ResolvedTx{..} spentInputsCoins gainedOutputsCoins allOurs acco -- represented here. data ResolvedBlock = ResolvedBlock { -- | Transactions in the block - _rbTxs :: ![ResolvedTx] + _rbTxs :: ![ResolvedTx] - -- | Slot ID of this block - , _rbSlotId :: !SlotId + -- | Block context + , _rbContext :: !BlockContext -- | Creation time of this block - , _rbMeta :: !Timestamp + , _rbMeta :: !Timestamp } makeLenses ''ResolvedTx diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec.hs index e372df9b412..f061833b0c3 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec.hs @@ -9,10 +9,11 @@ module Cardano.Wallet.Kernel.DB.Spec ( , checkpointUtxoBalance , checkpointPending , checkpointBlockMeta - , checkpointSlotId , checkpointForeign + , checkpointContext -- * Partial checkpoints , PartialCheckpoint(..) + , initPartialCheckpoint , fromFullCheckpoint , toFullCheckpoint -- ** Lenses @@ -20,8 +21,8 @@ module Cardano.Wallet.Kernel.DB.Spec ( , pcheckpointUtxoBalance , pcheckpointPending , pcheckpointBlockMeta - , pcheckpointSlotId , pcheckpointForeign + , pcheckpointContext -- * Unify partial and full checkpoints , IsCheckpoint(..) , cpAddressMeta @@ -31,14 +32,16 @@ module Cardano.Wallet.Kernel.DB.Spec ( , currentUtxoBalance , currentPending , currentBlockMeta - , currentSlotId + , currentContext , currentAddressMeta , currentForeign + -- ** Convenience: accessors for other checkpoints + , oldestCheckpoint ) where import Universum -import Control.Lens (from, _Wrapped) +import Control.Lens (Getter, from, to, _Wrapped) import Control.Lens.TH (makeLenses) import Data.Coerce (coerce) import Data.SafeCopy (base, deriveSafeCopy) @@ -50,6 +53,7 @@ import qualified Pos.Chain.Txp as Core import qualified Pos.Core as Core import Pos.Core.Chrono (NewestFirst) +import Cardano.Wallet.Kernel.DB.BlockContext import Cardano.Wallet.Kernel.DB.BlockMeta import Cardano.Wallet.Kernel.DB.InDb import Cardano.Wallet.Kernel.DB.Spec.Pending (Pending) @@ -58,6 +62,8 @@ import Cardano.Wallet.Kernel.Util.Core as Core import Cardano.Wallet.Kernel.Util.StrictNonEmpty (StrictNonEmpty (..)) import qualified Cardano.Wallet.Kernel.Util.StrictNonEmpty as SNE +{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} + {------------------------------------------------------------------------------- Wallet state as mandated by the spec -------------------------------------------------------------------------------} @@ -84,19 +90,28 @@ data Checkpoint = Checkpoint { , _checkpointPending :: !Pending , _checkpointBlockMeta :: !BlockMeta - -- | Slot ID associated with this checkpoint - -- - -- This is used for restoration to know (1) when we bridged the gap between - -- the partial current checkpoints and the full historical checkpoints and - -- (2) to be able to report how synchronization progress - , _checkpointSlotId :: !(InDb Core.SlotId) - -- Foreign pending transactions are transactions that transfer funds from -- /other/ wallets /to/ this wallet. An example are redemption -- certificates, which (logically) transfer money from an "AVVM wallet" to -- this one; crucially, this wallet would not recognize the input of a -- redemption transaction as " ours ". , _checkpointForeign :: !Pending + + -- | Block context of this block + -- + -- Set to 'Nothing' for the initial checkpoint only. + -- + -- The block context is used for a number of purposes: + -- + -- * During restoration we use it to check whether or not we have + -- bridged the gap between the current and historical checkpoints, + -- as well as for reporting progress. + -- * When applying a block, it is used to determine whether the wallet + -- behind have fallen behind the node. (This will happen only under + -- exceptional circumstances: for example, when the node informs the + -- wallet of a new block, but the wallet crashes or is terminated before + -- it can process the block.) + , _checkpointContext :: !(Maybe BlockContext) } makeLenses ''Checkpoint @@ -108,10 +123,6 @@ deriveSafeCopy 1 'base ''Checkpoint -- This takes a UTxO as argument to allow for wallets that are given an initial -- UTxO in the genesis block (note that we never roll back past the initial -- checkpoint). --- --- The slot ID for all initial checkpoints is always set to slot 0 of epoch 0. --- One way to think about this is that semantically we regard all accounts to --- be created at the beginning of time. initCheckpoint :: Core.Utxo -> Checkpoint initCheckpoint utxo = Checkpoint { _checkpointUtxo = InDb utxo @@ -120,9 +131,7 @@ initCheckpoint utxo = Checkpoint { , _checkpointPending = Pending.empty , _checkpointForeign = Pending.empty , _checkpointBlockMeta = emptyBlockMeta - , _checkpointSlotId = InDb $ Core.SlotId - (Core.EpochIndex 0) - (Core.UnsafeLocalSlotIndex 0) + , _checkpointContext = Nothing } {------------------------------------------------------------------------------- @@ -142,14 +151,39 @@ data PartialCheckpoint = PartialCheckpoint { , _pcheckpointUtxoBalance :: !(InDb Core.Coin) , _pcheckpointPending :: !Pending , _pcheckpointBlockMeta :: !LocalBlockMeta - , _pcheckpointSlotId :: !(InDb Core.SlotId) , _pcheckpointForeign :: !Pending + , _pcheckpointContext :: !(Maybe BlockContext) } makeLenses ''PartialCheckpoint deriveSafeCopy 1 'base ''PartialCheckpoint +-- | Initial partial checkpoint when we are restoring a wallet +-- +-- NOTE: The UTxO for the partial checkpoint must be obtained by looking at the +-- UTxO of the underlying full node. HOWEVER, we do not have access to the +-- block metadata for the most recent block! We have (partial) block metadata +-- for all blocks /after/ the initial partial checkpoint, and we have (complete) +-- block metadata for all historical checkpoints that we recover, but this is +-- only checkpoint for which we have no block metadata at all. Therefore we set +-- the block metadata to 'emptyBlockMeta'. Then during restoration when we are +-- recovering historical checkpoints, we don't stop until the historical +-- checkpoints /overlap/ one block with the partial checkpoints, so that the +-- block metadata of this initial partial checkpoint is not used. +-- +-- See also 'finishRestoration'. +initPartialCheckpoint :: Core.Utxo -> PartialCheckpoint +initPartialCheckpoint utxo = PartialCheckpoint { + _pcheckpointUtxo = InDb $ utxo + , _pcheckpointUtxoBalance = InDb $ Core.unsafeIntegerToCoin $ + Core.utxoBalance utxo + , _pcheckpointPending = Pending.empty + , _pcheckpointForeign = Pending.empty + , _pcheckpointBlockMeta = LocalBlockMeta emptyBlockMeta + , _pcheckpointContext = Nothing + } + -- | A full check point can be " downcast " to a partial checkpoint by -- forgetting that we have complete block metadata. -- @@ -165,8 +199,8 @@ fromFullCheckpoint f cp = inj <$> f (proj cp) , _pcheckpointUtxoBalance = _checkpointUtxoBalance , _pcheckpointPending = _checkpointPending , _pcheckpointBlockMeta = coerce _checkpointBlockMeta - , _pcheckpointSlotId = _checkpointSlotId , _pcheckpointForeign = _checkpointForeign + , _pcheckpointContext = _checkpointContext } inj :: PartialCheckpoint -> Checkpoint @@ -175,43 +209,24 @@ fromFullCheckpoint f cp = inj <$> f (proj cp) , _checkpointUtxoBalance = _pcheckpointUtxoBalance , _checkpointPending = _pcheckpointPending , _checkpointBlockMeta = coerce _pcheckpointBlockMeta - , _checkpointSlotId = _pcheckpointSlotId , _checkpointForeign = _pcheckpointForeign + , _checkpointContext = _pcheckpointContext } --- | Construct a full checkpoint from a partial checkpoint --- --- We can do this only given the block metadata of the previous block. We --- ask for the full previous checkpoint so that we can do a sanity check that --- the checkpoints line up. -toFullCheckpoint :: Checkpoint -> PartialCheckpoint -> Checkpoint -toFullCheckpoint prev PartialCheckpoint{..} = - if _pcheckpointSlotId `succeeds` _checkpointSlotId prev - then Checkpoint { - _checkpointUtxo = _pcheckpointUtxo - , _checkpointUtxoBalance = _pcheckpointUtxoBalance - , _checkpointPending = _pcheckpointPending - , _checkpointBlockMeta = withPrev _pcheckpointBlockMeta - , _checkpointSlotId = _pcheckpointSlotId - , _checkpointForeign = _pcheckpointForeign - } - else error "toFullCheckpoint: checkpoints do not line up" +-- | Construct a full checkpoint from a partial checkpoint and the block meta +-- of chain before the first partial checkpoint. +toFullCheckpoint :: BlockMeta -> PartialCheckpoint -> Checkpoint +toFullCheckpoint prevBlockMeta PartialCheckpoint{..} = Checkpoint { + _checkpointUtxo = _pcheckpointUtxo + , _checkpointUtxoBalance = _pcheckpointUtxoBalance + , _checkpointPending = _pcheckpointPending + , _checkpointBlockMeta = withPrev _pcheckpointBlockMeta + , _checkpointContext = _pcheckpointContext + , _checkpointForeign = _pcheckpointForeign + } where withPrev :: LocalBlockMeta -> BlockMeta - withPrev = appendBlockMeta (_checkpointBlockMeta prev) - - -- We cannot check whether this is the _direct_ successor, since - -- - -- 1. We don't know how many blocks in an epoch - -- (though we could conceivably pass that in as an argument) - -- 2. We may be skipping an EBB - succeeds :: InDb Core.SlotId -> InDb Core.SlotId -> Bool - InDb a `succeeds` InDb b = or [ - Core.siEpoch a > Core.siEpoch b - , and [ Core.siEpoch a == Core.siEpoch b - , Core.siSlot a > Core.siSlot b - ] - ] + withPrev = appendBlockMeta prevBlockMeta {------------------------------------------------------------------------------- Unify over full and partial checkpoints @@ -235,24 +250,24 @@ class IsCheckpoint c where cpUtxoBalance :: Lens' c Core.Coin cpPending :: Lens' c Pending cpBlockMeta :: Lens' c LocalBlockMeta - cpSlotId :: Lens' c Core.SlotId cpForeign :: Lens' c Pending + cpContext :: Lens' c (Maybe BlockContext) instance IsCheckpoint Checkpoint where cpUtxo = checkpointUtxo . fromDb cpUtxoBalance = checkpointUtxoBalance . fromDb cpPending = checkpointPending cpBlockMeta = checkpointBlockMeta . from _Wrapped - cpSlotId = checkpointSlotId . fromDb cpForeign = checkpointForeign + cpContext = checkpointContext instance IsCheckpoint PartialCheckpoint where cpUtxo = pcheckpointUtxo . fromDb cpUtxoBalance = pcheckpointUtxoBalance . fromDb cpPending = pcheckpointPending cpBlockMeta = pcheckpointBlockMeta - cpSlotId = pcheckpointSlotId . fromDb cpForeign = pcheckpointForeign + cpContext = pcheckpointContext cpAddressMeta :: IsCheckpoint c => Core.Address -> Lens' c AddressMeta cpAddressMeta addr = cpBlockMeta . _Wrapped . addressMeta addr @@ -264,21 +279,29 @@ cpAddressMeta addr = cpBlockMeta . _Wrapped . addressMeta addr currentCheckpoint :: Lens' (NewestFirst StrictNonEmpty c) c currentCheckpoint = _Wrapped . SNE.head -currentUtxo :: IsCheckpoint c => Lens' (NewestFirst StrictNonEmpty c) Core.Utxo -currentUtxoBalance :: IsCheckpoint c => Lens' (NewestFirst StrictNonEmpty c) Core.Coin -currentPending :: IsCheckpoint c => Lens' (NewestFirst StrictNonEmpty c) Pending -currentBlockMeta :: IsCheckpoint c => Lens' (NewestFirst StrictNonEmpty c) LocalBlockMeta -currentSlotId :: IsCheckpoint c => Lens' (NewestFirst StrictNonEmpty c) Core.SlotId -currentAddressMeta :: IsCheckpoint c => Core.Address -> Lens' (NewestFirst StrictNonEmpty c) AddressMeta -currentForeign :: IsCheckpoint c => Lens' (NewestFirst StrictNonEmpty c) Pending +currentUtxo :: IsCheckpoint c => Lens' (NewestFirst StrictNonEmpty c) Core.Utxo +currentUtxoBalance :: IsCheckpoint c => Lens' (NewestFirst StrictNonEmpty c) Core.Coin +currentPending :: IsCheckpoint c => Lens' (NewestFirst StrictNonEmpty c) Pending +currentBlockMeta :: IsCheckpoint c => Lens' (NewestFirst StrictNonEmpty c) LocalBlockMeta +currentForeign :: IsCheckpoint c => Lens' (NewestFirst StrictNonEmpty c) Pending +currentContext :: IsCheckpoint c => Lens' (NewestFirst StrictNonEmpty c) (Maybe BlockContext) + +currentUtxo = currentCheckpoint . cpUtxo +currentUtxoBalance = currentCheckpoint . cpUtxoBalance +currentPending = currentCheckpoint . cpPending +currentBlockMeta = currentCheckpoint . cpBlockMeta +currentForeign = currentCheckpoint . cpForeign +currentContext = currentCheckpoint . cpContext -currentUtxo = currentCheckpoint . cpUtxo -currentUtxoBalance = currentCheckpoint . cpUtxoBalance -currentPending = currentCheckpoint . cpPending -currentBlockMeta = currentCheckpoint . cpBlockMeta -currentSlotId = currentCheckpoint . cpSlotId +currentAddressMeta :: IsCheckpoint c => Core.Address -> Lens' (NewestFirst StrictNonEmpty c) AddressMeta currentAddressMeta addr = currentCheckpoint . cpAddressMeta addr -currentForeign = currentCheckpoint . cpForeign + +{------------------------------------------------------------------------------- + Convenience: accessors for other checkpoints +-------------------------------------------------------------------------------} + +oldestCheckpoint :: Getter (NewestFirst StrictNonEmpty c) c +oldestCheckpoint = _Wrapped . to SNE.last {------------------------------------------------------------------------------- Pretty-printing @@ -286,14 +309,36 @@ currentForeign = currentCheckpoint . cpForeign instance Buildable Checkpoint where build Checkpoint{..} = bprint - ( "Checkpoint" + ( "Checkpoint " + % "{ utxo: " % mapJson + % ", utxoBalance: " % build + % ", pending: " % build + % ", blockMeta: " % build + % ", context: " % build + % ", foreign: " % build + % "}" + ) + (_fromDb _checkpointUtxo) + (_fromDb _checkpointUtxoBalance) + _checkpointPending + _checkpointBlockMeta + _checkpointContext + _checkpointForeign + +instance Buildable PartialCheckpoint where + build PartialCheckpoint{..} = bprint + ( "PartialCheckpoint " % "{ utxo: " % mapJson % ", utxoBalance: " % build % ", pending: " % build % ", blockMeta: " % build + % ", context: " % build + % ", foreign: " % build % "}" ) - (_fromDb _checkpointUtxo) - (_fromDb _checkpointUtxoBalance) - _checkpointPending - _checkpointBlockMeta + (_fromDb _pcheckpointUtxo) + (_fromDb _pcheckpointUtxoBalance) + _pcheckpointPending + _pcheckpointBlockMeta + _pcheckpointContext + _pcheckpointForeign diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Update.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Update.hs index fd8ed982363..45b87885f02 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Update.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Update.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} -- | UPDATE operations on the wallet-spec state @@ -6,6 +7,7 @@ module Cardano.Wallet.Kernel.DB.Spec.Update ( -- * Errors NewPendingFailed(..) , NewForeignFailed(..) + , ApplyBlockFailed(..) -- * Updates , newPending , newForeign @@ -22,17 +24,17 @@ import Universum hiding ((:|)) import qualified Data.Map.Strict as Map import Data.SafeCopy (base, deriveSafeCopy) import qualified Data.Set as Set -import Formatting (bprint, (%)) +import Formatting (bprint, build, (%)) import qualified Formatting.Buildable import Serokell.Util (listJsonIndent) -import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck (Arbitrary (..), elements) import Pos.Chain.Txp (Utxo) import qualified Pos.Core as Core import Pos.Core.Chrono (NewestFirst (..), OldestFirst (..)) -import Pos.Core.Slotting (SlotId) import qualified Pos.Core.Txp as Txp +import Cardano.Wallet.Kernel.DB.BlockContext import Cardano.Wallet.Kernel.DB.BlockMeta import Cardano.Wallet.Kernel.DB.InDb import Cardano.Wallet.Kernel.DB.Spec @@ -82,6 +84,33 @@ instance Buildable NewForeignFailed where instance Arbitrary NewForeignFailed where arbitrary = pure . NewForeignInputsAvailable . InDb $ mempty +-- | Errors thrown by 'applyBlock' +data ApplyBlockFailed = + -- | The block we're trying to apply does not fit onto the previous + -- + -- This indicates that the wallet has fallen behind the node (for example, + -- when the node informs the wallet of a block but the wallet gets + -- shut down before it gets a chance to process it). + -- + -- We record the context of the block we're trying to apply and the + -- context of the most recent checkpoint. + ApplyBlockNotSuccessor BlockContext (Maybe BlockContext) + +deriveSafeCopy 1 'base ''ApplyBlockFailed + +instance Buildable ApplyBlockFailed where + build (ApplyBlockNotSuccessor context checkpoint) = bprint + ("ApplyBlockNotSuccessor " + % "{ context: " % build + % ", checkpoint: " % build + % "}" + ) + context + checkpoint + +instance Arbitrary ApplyBlockFailed where + arbitrary = elements [] + {------------------------------------------------------------------------------- Wallet spec mandated updates -------------------------------------------------------------------------------} @@ -149,55 +178,66 @@ cancelPending txids = map (cpPending %~ Pending.delete txids) -- -- Additionally returns the set of transactions removed from pending. applyBlock :: SecurityParameter - -> SlotId -> PrefilteredBlock - -> NewestFirst StrictNonEmpty Checkpoint - -> (NewestFirst StrictNonEmpty Checkpoint, Set Txp.TxId) -applyBlock (SecurityParameter k) slotId pb checkpoints = ( - takeNewest k $ NewestFirst $ Checkpoint { + -> Update' (NewestFirst StrictNonEmpty Checkpoint) + ApplyBlockFailed + (Set Txp.TxId) +applyBlock (SecurityParameter k) pb = do + checkpoints <- get + let current = checkpoints ^. currentCheckpoint + utxo = current ^. checkpointUtxo . fromDb + balance = current ^. checkpointUtxoBalance . fromDb + (utxo', balance') = updateUtxo pb (utxo, balance) + (pending', rem1) = updatePending pb (current ^. checkpointPending) + blockMeta' = updateBlockMeta pb (current ^. checkpointBlockMeta) + (foreign', rem2) = updatePending pb (current ^. checkpointForeign) + if (pfbContext pb) `blockContextSucceeds` (current ^. checkpointContext) then do + put $ takeNewest k $ NewestFirst $ Checkpoint { _checkpointUtxo = InDb utxo' , _checkpointUtxoBalance = InDb balance' , _checkpointPending = pending' , _checkpointBlockMeta = blockMeta' - , _checkpointSlotId = InDb slotId , _checkpointForeign = foreign' + , _checkpointContext = Just $ pfbContext pb } SNE.<| getNewestFirst checkpoints - , Set.unions [rem1, rem2] - ) - where - current = checkpoints ^. currentCheckpoint - utxo = current ^. checkpointUtxo . fromDb - balance = current ^. checkpointUtxoBalance . fromDb - (utxo', balance') = updateUtxo pb (utxo, balance) - (pending', rem1) = updatePending pb (current ^. checkpointPending) - blockMeta' = updateBlockMeta pb (current ^. checkpointBlockMeta) - (foreign', rem2) = updatePending pb (current ^. checkpointForeign) + return $ Set.unions [rem1, rem2] + else + throwError $ ApplyBlockNotSuccessor + (pfbContext pb) + (current ^. checkpointContext) -- | Like 'applyBlock', but to a list of partial checkpoints instead -applyBlockPartial :: SecurityParameter - -> SlotId - -> PrefilteredBlock - -> NewestFirst StrictNonEmpty PartialCheckpoint - -> (NewestFirst StrictNonEmpty PartialCheckpoint, Set Txp.TxId) -applyBlockPartial (SecurityParameter k) slotId pb checkpoints = ( - takeNewest k $ NewestFirst $ PartialCheckpoint { +-- +-- NOTE: Unlike 'applyBlock', we do /NOT/ throw away partial checkpoints. If +-- we did, it might be impossible for the historical checkpoints to ever +-- catch up with the current ones. +applyBlockPartial :: PrefilteredBlock + -> Update' (NewestFirst StrictNonEmpty PartialCheckpoint) + ApplyBlockFailed + (Set Txp.TxId) +applyBlockPartial pb = do + checkpoints <- get + let current = checkpoints ^. currentCheckpoint + utxo = current ^. pcheckpointUtxo . fromDb + balance = current ^. pcheckpointUtxoBalance . fromDb + (utxo', balance') = updateUtxo pb (utxo, balance) + (pending', rem1) = updatePending pb (current ^. pcheckpointPending) + blockMeta' = updateLocalBlockMeta pb (current ^. pcheckpointBlockMeta) + (foreign', rem2) = updatePending pb (current ^. pcheckpointForeign) + if (pfbContext pb) `blockContextSucceeds` (current ^. pcheckpointContext) then do + put $ NewestFirst $ PartialCheckpoint { _pcheckpointUtxo = InDb utxo' , _pcheckpointUtxoBalance = InDb balance' , _pcheckpointPending = pending' , _pcheckpointBlockMeta = blockMeta' - , _pcheckpointSlotId = InDb slotId , _pcheckpointForeign = foreign' + , _pcheckpointContext = Just $ pfbContext pb } SNE.<| getNewestFirst checkpoints - , Set.unions [rem1, rem2] - ) - where - current = checkpoints ^. currentCheckpoint - utxo = current ^. pcheckpointUtxo . fromDb - balance = current ^. pcheckpointUtxoBalance . fromDb - (utxo', balance') = updateUtxo pb (utxo, balance) - (pending', rem1) = updatePending pb (current ^. pcheckpointPending) - blockMeta' = updateLocalBlockMeta pb (current ^. pcheckpointBlockMeta) - (foreign', rem2) = updatePending pb (current ^. pcheckpointForeign) + return $ Set.unions [rem1, rem2] + else + throwError $ ApplyBlockNotSuccessor + (pfbContext pb) + (current ^. pcheckpointContext) -- | Rollback -- @@ -211,29 +251,29 @@ applyBlockPartial (SecurityParameter k) slotId pb checkpoints = ( -- so that the submission layer can start sending those out again. -- -- This is an internal function only, and not exported. See 'switchToFork'. -rollback :: NewestFirst StrictNonEmpty Checkpoint - -> (NewestFirst StrictNonEmpty Checkpoint, Pending) -rollback (NewestFirst (c :| SL.Nil)) = (NewestFirst $ c :| SL.Nil, Pending.empty) -rollback (NewestFirst (c :| SL.Cons c' cs)) = (NewestFirst $ Checkpoint { - _checkpointUtxo = c' ^. checkpointUtxo - , _checkpointUtxoBalance = c' ^. checkpointUtxoBalance - , _checkpointBlockMeta = c' ^. checkpointBlockMeta - , _checkpointSlotId = c' ^. checkpointSlotId - , _checkpointPending = Pending.union (c ^. checkpointPending) - (c' ^. checkpointPending) - , _checkpointForeign = Pending.union (c ^. checkpointForeign) - (c' ^. checkpointForeign) - } :| cs - , Pending.union - ((c' ^. checkpointPending) Pending.\\ (c ^. checkpointPending)) - ((c' ^. checkpointForeign) Pending.\\ (c ^. checkpointForeign)) - ) +rollback :: Update' (NewestFirst StrictNonEmpty Checkpoint) e Pending +rollback = state $ \case + NewestFirst (c :| SL.Nil) -> (Pending.empty, NewestFirst $ c :| SL.Nil) + NewestFirst (c :| SL.Cons c' cs) -> ( + Pending.union + ((c' ^. checkpointPending) Pending.\\ (c ^. checkpointPending)) + ((c' ^. checkpointForeign) Pending.\\ (c ^. checkpointForeign)) + , NewestFirst $ Checkpoint { + _checkpointUtxo = c' ^. checkpointUtxo + , _checkpointUtxoBalance = c' ^. checkpointUtxoBalance + , _checkpointBlockMeta = c' ^. checkpointBlockMeta + , _checkpointContext = c' ^. checkpointContext + , _checkpointPending = Pending.union (c ^. checkpointPending) + (c' ^. checkpointPending) + , _checkpointForeign = Pending.union (c ^. checkpointForeign) + (c' ^. checkpointForeign) + } :| cs + ) -- | Observable rollback, used in testing only -- -- See 'switchToFork' for production use. -observableRollbackUseInTestsOnly :: NewestFirst StrictNonEmpty Checkpoint - -> (NewestFirst StrictNonEmpty Checkpoint, Pending) +observableRollbackUseInTestsOnly :: Update' (NewestFirst StrictNonEmpty Checkpoint) e Pending observableRollbackUseInTestsOnly = rollback -- | Switch to a fork @@ -246,41 +286,36 @@ observableRollbackUseInTestsOnly = rollback -- (since they are new confirmed). switchToFork :: SecurityParameter -> Int -- ^ Number of blocks to rollback - -> OldestFirst [] (SlotId, PrefilteredBlock) -- ^ Blocks to apply - -> NewestFirst StrictNonEmpty Checkpoint - -> (NewestFirst StrictNonEmpty Checkpoint, (Pending, Set Txp.TxId)) -switchToFork k numRollbacks blocksToApply = \cps -> - rollbacks Pending.empty numRollbacks cps + -> OldestFirst [] PrefilteredBlock -- ^ Blocks to apply + -> Update' (NewestFirst StrictNonEmpty Checkpoint) + ApplyBlockFailed + (Pending, Set Txp.TxId) +switchToFork k numRollbacks blocksToApply = do + reintroduced <- rollbacks Pending.empty numRollbacks + applyBlocks reintroduced Set.empty (getOldestFirst blocksToApply) where rollbacks :: Pending -- Accumulator: reintroduced pending transactions - -> Int - -> NewestFirst StrictNonEmpty Checkpoint - -> (NewestFirst StrictNonEmpty Checkpoint, (Pending, Set Txp.TxId)) - rollbacks !accNew 0 cps = - applyBlocks - accNew - Set.empty - (getOldestFirst blocksToApply) - cps - rollbacks !accNew n cps = - rollbacks (Pending.union accNew reintroduced) (n - 1) cps' - where - (cps', reintroduced) = rollback cps + -> Int -- Number of rollback to do + -> Update' (NewestFirst StrictNonEmpty Checkpoint) + e + Pending + rollbacks !accNew 0 = return accNew + rollbacks !accNew n = do + reintroduced <- rollback + rollbacks (Pending.union accNew reintroduced) (n - 1) applyBlocks :: Pending -- Accumulator: reintroduced pending transactions -> Set Txp.TxId -- Accumulator: removed pending transactions - -> [(SlotId, PrefilteredBlock)] - -> NewestFirst StrictNonEmpty Checkpoint - -> (NewestFirst StrictNonEmpty Checkpoint, (Pending, Set Txp.TxId)) - applyBlocks !accNew !accRem [] cps = (cps, (accNew, accRem)) - applyBlocks !accNew !accRem ((slotId, b):bs) cps = - applyBlocks - (Pending.delete removed accNew) - (Set.union removed accRem) - bs - cps' - where - (cps', removed) = applyBlock k slotId b cps + -> [PrefilteredBlock] + -> Update' (NewestFirst StrictNonEmpty Checkpoint) + ApplyBlockFailed + (Pending, Set Txp.TxId) + applyBlocks !accNew !accRem [] = return (accNew, accRem) + applyBlocks !accNew !accRem (b:bs) = do + removed <- applyBlock k b + applyBlocks (Pending.delete removed accNew) + (Set.union removed accRem) + bs {------------------------------------------------------------------------------- Internal auxiliary diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/Util/AcidState.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/Util/AcidState.hs index b9a2818bc55..b877c753f03 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/DB/Util/AcidState.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/Util/AcidState.hs @@ -24,6 +24,7 @@ module Cardano.Wallet.Kernel.DB.Util.AcidState ( , zoomDef , zoomCreate , zoomAll + , zoomAll_ -- ** Convenience re-exports , throwError ) where @@ -228,3 +229,13 @@ zoomAll l (Update' upd) = Update' $ strictStateT $ \large -> do let update (ixset', bs) = (Map.fromList bs, large & l .~ ixset') ixset = large ^. l update <$> IxSet.otraverseCollect (fmap swap . runStrictStateT upd) ixset + +-- | Variation on 'zoomAll' with no return values +zoomAll_ :: (Indexable a) + => Lens' st (IxSet a) + -> Update' a e () + -> Update' st e () +zoomAll_ l (Update' upd) = Update' $ strictStateT $ \large -> do + let update ixset' = ((), large & l .~ ixset') + ixset = large ^. l + update <$> IxSet.otraverse (execStrictStateT upd) ixset diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Decrypt.hs b/wallet-new/src/Cardano/Wallet/Kernel/Decrypt.hs new file mode 100644 index 00000000000..e13c97a809d --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/Decrypt.hs @@ -0,0 +1,8 @@ +module Cardano.Wallet.Kernel.Decrypt + ( decryptAddress + , keyToWalletDecrCredentials + , WalletDecrCredentials + , WalletDecrCredentialsKey(..) + ) where + +import Pos.Wallet.Web.Tracking.Decrypt diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Internal.hs b/wallet-new/src/Cardano/Wallet/Kernel/Internal.hs index eecdd0e4720..1dbaf0193b3 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Internal.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Internal.hs @@ -9,6 +9,7 @@ module Cardano.Wallet.Kernel.Internal ( -- * Passive wallet PassiveWallet(..) + , WalletRestorationInfo(..) -- ** Lenses , walletKeystore , walletMeta @@ -16,6 +17,11 @@ module Cardano.Wallet.Kernel.Internal ( , walletLogMessage , walletNode , walletSubmission + , walletRestorationTask + , wriCurrentSlot + , wriTargetSlot + , wriThroughput + , wriCancel -- * Active wallet , ActiveWallet(..) ) where @@ -25,15 +31,40 @@ import Universum hiding (State) import Control.Lens.TH import Data.Acid (AcidState) -import Pos.Core (ProtocolMagic) +import Pos.Core (BlockCount, FlatSlotId, ProtocolMagic) import Pos.Util.Wlog (Severity (..)) +import Cardano.Wallet.API.Types.UnitOfMeasure (MeasuredIn (..), + UnitOfMeasure (..)) import Cardano.Wallet.Kernel.DB.AcidState (DB) import Cardano.Wallet.Kernel.DB.TxMeta import Cardano.Wallet.Kernel.Diffusion (WalletDiffusion (..)) import Cardano.Wallet.Kernel.Keystore (Keystore) import Cardano.Wallet.Kernel.NodeStateAdaptor (NodeStateAdaptor) import Cardano.Wallet.Kernel.Submission (WalletSubmission) +import Cardano.Wallet.Kernel.Types (WalletId) + +{------------------------------------------------------------------------------- + Restoration status +-------------------------------------------------------------------------------} + +-- | Wallet restoration information +-- +-- The restoration info tracks the progress of a background wallet +-- restoration task currently in progress. In addition to giving +-- visibility into a restoration task, it also provides an action +-- that can be used to cancel the background restoration task. +data WalletRestorationInfo = WalletRestorationInfo + { _wriCurrentSlot :: FlatSlotId + -- ^ The most recently restored slot + , _wriTargetSlot :: FlatSlotId + -- ^ The target slot; when restoration reaches this slot, + -- it is finished and the wallet is up-to-date. + , _wriThroughput :: MeasuredIn 'BlocksPerSecond BlockCount + -- ^ Speed of restoration. + , _wriCancel :: IO () + -- ^ The action that can be used to cancel the restoration task. + } {------------------------------------------------------------------------------- Passive wallet @@ -46,16 +77,16 @@ import Cardano.Wallet.Kernel.Submission (WalletSubmission) -- data PassiveWallet = PassiveWallet { -- | Send log message - _walletLogMessage :: Severity -> Text -> IO () + _walletLogMessage :: Severity -> Text -> IO () -- | Logger - , _walletKeystore :: Keystore + , _walletKeystore :: Keystore -- | An opaque handle to a place where we store the 'EncryptedSecretKey'. - , _wallets :: AcidState DB + , _wallets :: AcidState DB -- | Database handle - , _walletMeta :: MetaDBHandle + , _walletMeta :: MetaDBHandle -- | Access to the underlying node -- @@ -68,7 +99,7 @@ data PassiveWallet = PassiveWallet { -- -- The primary function of this is wallet restoration, where the wallet's -- own DB /cannot/ be consulted. - , _walletNode :: NodeStateAdaptor IO + , _walletNode :: NodeStateAdaptor IO -- | The wallet submission layer -- @@ -83,11 +114,20 @@ data PassiveWallet = PassiveWallet { -- the active part actually sends stuff across the network. Fortunately, -- we already have this split: the submission layer itself is just a -- pure data structure, and the sending happens in a separate thread. - , _walletSubmission :: MVar WalletSubmission + , _walletSubmission :: MVar WalletSubmission + + -- | Wallet restoration tasks. Wallets that are in the midst of a restoration + -- will be doing background work to restore the history. This map holds a + -- reference to the restoration background task, along with the current status + -- of the task. + -- + -- The invariant is that a WalletId should appear in this map if and only if + -- that wallet is still undergoing restoration. + , _walletRestorationTask :: MVar (Map WalletId WalletRestorationInfo) } makeLenses ''PassiveWallet - +makeLenses ''WalletRestorationInfo {------------------------------------------------------------------------------- Active wallet diff --git a/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs b/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs index 824e7b4b7ce..ad2cb34ae2b 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs @@ -31,6 +31,7 @@ module Cardano.Wallet.Kernel.NodeStateAdaptor ( , mostRecentMainBlock , triggerShutdown , waitForUpdate + , defaultGetSlotStart -- * Support for tests , NodeStateUnavailable(..) , MockNodeStateParams(..) @@ -88,7 +89,6 @@ import Pos.Util (CompileTimeInfo, HasCompileInfo, HasLens (..), import qualified Pos.Util as Util import Pos.Util.Concurrent.PriorityLock (Priority (..)) import Pos.Util.Wlog (CanLog (..), HasLoggerName (..)) - import Test.Pos.Configuration (withDefConfiguration, withDefUpdateConfiguration) diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Pending.hs b/wallet-new/src/Cardano/Wallet/Kernel/Pending.hs index 905eb7dc091..87e3c1def5a 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Pending.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Pending.hs @@ -118,7 +118,7 @@ newTx ActiveWallet{..} accountId tx partialMeta upd = do ourAddrs esk = map f $ filterOurs wKey txOutAddress txOut where - f (txOut',addressId) = (initHdAddress addressId (InDb (txOutAddress txOut')), txOutValue txOut') + f (txOut',addressId) = (initHdAddress addressId (txOutAddress txOut'), txOutValue txOut') wKey = (wid, keyToWalletDecrCredentials $ KeyForRegular esk) submitTx :: IO () diff --git a/wallet-new/src/Cardano/Wallet/Kernel/PrefilterTx.hs b/wallet-new/src/Cardano/Wallet/Kernel/PrefilterTx.hs index 6065eb59f6a..42c4c877b4f 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/PrefilterTx.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/PrefilterTx.hs @@ -8,7 +8,12 @@ module Cardano.Wallet.Kernel.PrefilterTx , AddrWithId , prefilterBlock , prefilterUtxo + , UtxoWithAddrId + , prefilterUtxo' , filterOurs + , toHdAddressId + , WalletKey + , toPrefilteredUtxo ) where import Universum @@ -33,11 +38,12 @@ import Pos.Wallet.Web.Tracking.Decrypt (WalletDecrCredentials, WalletDecrCredentialsKey (..), keyToWalletDecrCredentials, selectOwnAddresses) +import Cardano.Wallet.Kernel.DB.BlockContext import Cardano.Wallet.Kernel.DB.BlockMeta import Cardano.Wallet.Kernel.DB.HdWallet import Cardano.Wallet.Kernel.DB.InDb (InDb (..), fromDb) import Cardano.Wallet.Kernel.DB.Resolved (ResolvedBlock, - ResolvedInput, ResolvedTx, rbSlotId, rbTxs, + ResolvedInput, ResolvedTx, rbContext, rbTxs, resolvedToTxMeta, rtxInputs, rtxOutputs) import Cardano.Wallet.Kernel.DB.TxMeta.Types import Cardano.Wallet.Kernel.Types (WalletId (..)) @@ -45,7 +51,7 @@ import Cardano.Wallet.Kernel.Util.Core {------------------------------------------------------------------------------- Pre-filter Tx Inputs and Outputs; pre-filter a block of transactions. -+-------------------------------------------------------------------------------} +-------------------------------------------------------------------------------} -- | Address extended with an HdAddressId, which embeds information that places -- the Address in the context of the Wallet/Accounts/Addresses hierarchy. @@ -67,6 +73,9 @@ data PrefilteredBlock = PrefilteredBlock { -- | Prefiltered block metadata , pfbMeta :: !LocalBlockMeta + + -- | Block context + , pfbContext :: !BlockContext } deriveSafeCopy 1 'base ''PrefilteredBlock @@ -76,13 +85,13 @@ deriveSafeCopy 1 'base ''PrefilteredBlock -- An empty prefiltered block is what we get when we filter a block for a -- particular account and there is nothing in the block that is of -- relevance to that account -emptyPrefilteredBlock :: PrefilteredBlock -emptyPrefilteredBlock = PrefilteredBlock { +emptyPrefilteredBlock :: BlockContext -> PrefilteredBlock +emptyPrefilteredBlock context = PrefilteredBlock { pfbInputs = Set.empty , pfbOutputs = Map.empty , pfbAddrs = [] , pfbMeta = emptyLocalBlockMeta - + , pfbContext = context } type WalletKey = (WalletId, WalletDecrCredentials) @@ -114,7 +123,7 @@ type UtxoSummaryRaw = Map TxIn (TxOutAux,AddressSummary) {------------------------------------------------------------------------------- Pre-filter Tx Inputs and Outputs to those that belong to the given Wallet. -+-------------------------------------------------------------------------------} +-------------------------------------------------------------------------------} -- | Prefilter the inputs and outputs of a resolved transaction. -- Prefiltered inputs and outputs are indexed by accountId. @@ -221,16 +230,15 @@ filterOurs :: WalletKey -> [(a, HdAddressId)] -- ^ matching items filterOurs (wid,wdc) selectAddr rtxs = map f $ selectOwnAddresses wdc selectAddr rtxs - where f (addr,meta) = (addr, toAddressId wid meta) + where f (addr,meta) = (addr, toHdAddressId wid meta) - toAddressId :: WalletId -> WAddressMeta -> HdAddressId - toAddressId (WalletIdHdRnd rootId) meta' = addressId - where - accountIx = HdAccountIx (_wamAccountIndex meta') - accountId = HdAccountId rootId accountIx - - addressIx = HdAddressIx (_wamAddressIndex meta') - addressId = HdAddressId accountId addressIx +-- TODO (@mn): move this into Util or something +toHdAddressId :: WalletId -> WAddressMeta -> HdAddressId +toHdAddressId (WalletIdHdRnd rootId) meta' = HdAddressId accountId addressIx + where + accountIx = HdAccountIx (_wamAccountIndex meta') + accountId = HdAccountId rootId accountIx + addressIx = HdAddressIx (_wamAddressIndex meta') extendWithSummary :: (Bool, Bool) -- ^ Bools that indicate whether the inputs and outsputs are all "ours" @@ -255,7 +263,7 @@ extendWithSummary (onlyOurInps,onlyOurOuts) utxoWithAddrId {------------------------------------------------------------------------------- Pre-filter a block of transactions, adorn each prefiltered block with block metadata and Transaction metadata. -+-------------------------------------------------------------------------------} +-------------------------------------------------------------------------------} -- | Prefilter the transactions of a resolved block for the given wallet. -- @@ -266,7 +274,7 @@ prefilterBlock :: ResolvedBlock -> (Map HdAccountId PrefilteredBlock, [TxMeta]) prefilterBlock block wid esk = (Map.fromList - $ map (mkPrefBlock (block ^. rbSlotId) inpAll outAll) + $ map (mkPrefBlock (block ^. rbContext) inpAll outAll) $ Set.toList accountIds , metas) where @@ -287,16 +295,17 @@ prefilterBlock block wid esk = accountIds = Map.keysSet inpAll `Set.union` Map.keysSet outAll -mkPrefBlock :: SlotId +mkPrefBlock :: BlockContext -> Map HdAccountId (Set TxIn) -> Map HdAccountId (Map TxIn (TxOutAux, AddressSummary)) -> HdAccountId -> (HdAccountId, PrefilteredBlock) -mkPrefBlock slotId inps outs accId = (accId, PrefilteredBlock { +mkPrefBlock context inps outs accId = (accId, PrefilteredBlock { pfbInputs = inps' , pfbOutputs = outs' , pfbAddrs = addrs'' , pfbMeta = blockMeta' + , pfbContext = context }) where fromAddrSummary :: AddressSummary -> AddrWithId @@ -308,7 +317,7 @@ mkPrefBlock slotId inps outs accId = (accId, PrefilteredBlock { (outs', addrs') = fromUtxoSummary (byAccountId accId Map.empty outs) addrs'' = nub $ map fromAddrSummary addrs' - blockMeta' = mkBlockMeta slotId addrs' + blockMeta' = mkBlockMeta (context ^. bcSlotId . fromDb) addrs' mkBlockMeta :: SlotId -> [AddressSummary] -> LocalBlockMeta mkBlockMeta slotId addrs_ = LocalBlockMeta BlockMeta{..} diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Restore.hs b/wallet-new/src/Cardano/Wallet/Kernel/Restore.hs new file mode 100644 index 00000000000..70b0ed8ece2 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/Restore.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +module Cardano.Wallet.Kernel.Restore + ( restoreWallet + ) where + +import Universum + +import Control.Concurrent.Async (async, cancel) +import Control.Concurrent.MVar (modifyMVar_) +import Data.Acid (update) +import qualified Data.Map.Merge.Strict as M +import qualified Data.Map.Strict as M +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, + getCurrentTime) +import Formatting (bprint, build, formatToString, (%)) +import qualified Formatting.Buildable + +import qualified Prelude + +import Cardano.Wallet.API.Types.UnitOfMeasure +import Cardano.Wallet.Kernel (walletLogMessage) +import qualified Cardano.Wallet.Kernel as Kernel +import Cardano.Wallet.Kernel.DB.AcidState (ApplyHistoricalBlock (..), + CreateHdWallet (..), RestorationComplete (..), + RestoreHdWallet (..)) +import Cardano.Wallet.Kernel.DB.BlockContext +import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD +import Cardano.Wallet.Kernel.DB.HdWallet.Create (CreateHdRootError) +import qualified Cardano.Wallet.Kernel.DB.Spec.Update as Spec +import Cardano.Wallet.Kernel.DB.TxMeta.Types +import Cardano.Wallet.Kernel.Decrypt (WalletDecrCredentialsKey (..), + decryptAddress, keyToWalletDecrCredentials) +import Cardano.Wallet.Kernel.Internal (WalletRestorationInfo (..), + walletMeta, walletNode, walletRestorationTask, wallets, + wriCancel, wriCurrentSlot, wriTargetSlot, wriThroughput) +import Cardano.Wallet.Kernel.NodeStateAdaptor (Lock, LockContext (..), + NodeConstraints, WithNodeState, filterUtxo, + getSecurityParameter, getSlotCount, mostRecentMainBlock, + withNodeState) +import Cardano.Wallet.Kernel.PrefilterTx (AddrWithId, + PrefilteredBlock, UtxoWithAddrId, WalletKey, + prefilterUtxo', toHdAddressId, toPrefilteredUtxo) +import Cardano.Wallet.Kernel.Types (WalletId (..)) +import Cardano.Wallet.Kernel.Util.Core (utxoBalance) +import Cardano.Wallet.Kernel.Wallets (createWalletHdRnd) + +import Pos.Chain.Block (Block, Blund, HeaderHash, MainBlock, Undo, + headerHash, mainBlockSlot) +import Pos.Chain.Txp (GenesisUtxo (..), Utxo, genesisUtxo) +import Pos.Core (BlockCount (..), Coin, SlotId, flattenSlotIdExplicit, + mkCoin, unsafeIntegerToCoin) +import Pos.Core.Txp (TxIn (..), TxOut (..), TxOutAux (..)) +import Pos.Crypto (EncryptedSecretKey) +import Pos.DB.Block (getFirstGenesisBlockHash, getUndo, + resolveForwardLink) +import Pos.DB.Class (getBlock) +import Pos.Util.Trace (Severity (Error)) + +-- | Restore a wallet +-- +-- NOTE: The key for the wallet must already have been added to the keystore. +-- +-- Scan the node's current UTXO set for any that belong to this wallet. Use them +-- to update the current checkpoint's UTXO set, and return the total 'Coin' +-- value of the UTXO belonging to this wallet. At the same time, kick off a +-- background thread that will asynchronously restore the wallet history. +-- +-- Wallet initialization parameters match those of 'createWalletHdRnd' +restoreWallet :: Kernel.PassiveWallet + -> Bool -- ^ Spending password + -> HD.WalletName + -> HD.AssuranceLevel + -> EncryptedSecretKey + -> (Blund -> IO (Map HD.HdAccountId PrefilteredBlock, [TxMeta])) + -> IO (Either CreateHdRootError (HD.HdRoot, Coin)) +restoreWallet pw spendingPass name assurance esk prefilter = do + walletInitInfo <- withNodeState (pw ^. walletNode) $ getWalletInitInfo wkey + case walletInitInfo of + WalletCreate utxos -> do + root <- createWalletHdRnd pw spendingPass name assurance esk $ \root -> + Left $ CreateHdWallet root utxos + return $ fmap (, mkCoin 0) root + WalletRestore utxos (tgtTip, tgtSlot) -> do + -- Create the wallet + mRoot <- createWalletHdRnd pw spendingPass name assurance esk $ \root -> + Right $ RestoreHdWallet root utxos + case mRoot of + Left err -> return (Left err) + Right root -> do + -- Set the wallet's restoration information + slotCount <- getSlotCount (pw ^. walletNode) + let restoreInfo = WalletRestorationInfo + { _wriCurrentSlot = 0 + , _wriTargetSlot = flattenSlotIdExplicit slotCount tgtSlot + , _wriThroughput = MeasuredIn 0 + , _wriCancel = return () + } + modifyMVar_ (pw ^. walletRestorationTask) (pure . M.insert wId restoreInfo) + + -- Begin restoring the wallet history in the background. + restoreTask <- async $ + -- We are starting this async /from/ a thread that runs in response + -- to a REST request. Linking the async to that REST request thread + -- is pointless, because that thread will probably be long gone if + -- an exception ever happens in the restoration worker. Therefore + -- we just log any errors. + catch (restoreWalletHistoryAsync pw (root ^. HD.hdRootId) tgtTip tgtSlot prefilter) $ \(e :: SomeException) -> + (pw ^. walletLogMessage) Error ("Exception during restoration: " <> show e) + + -- Set up the cancellation action + updateRestorationInfo pw wId (wriCancel .~ cancel restoreTask) + + -- Return the wallet's current balance. + let balance = unsafeIntegerToCoin + . utxoBalance + . M.unions + . M.elems + . fmap (\(cur, _gen, _addrs) -> cur) + $ utxos + return $ Right (root, balance) + where + rootId = HD.eskToHdRootId esk + wId = WalletIdHdRnd rootId + wkey = (wId, keyToWalletDecrCredentials (KeyForRegular esk)) + +-- | Information we need to start the restoration process +data WalletInitInfo = + -- | Create the wallet, without actually restoring + -- + -- This is used only when the chain has no main blocks yet. We record + -- the only the genesis UTxO for the wallet, and any addresses we found. + WalletCreate + (Map HD.HdAccountId (Utxo, [AddrWithId])) + + -- | Restore the wallet + -- + -- We record the current and genesis UTxO, as well as some information + -- about the most recent main block on the chain. + | WalletRestore + (Map HD.HdAccountId (Utxo, Utxo, [AddrWithId])) + (HeaderHash, SlotId) + +-- | Query the underlying node for the info we need to restore a wallet +-- +-- We return the current and genesis UTxO for this wallet, as well some +-- information about the tip of the blockchain (provided the blockchain +-- isn't empty). +getWalletInitInfo :: NodeConstraints + => WalletKey + -> Lock (WithNodeState IO) + -> WithNodeState IO WalletInitInfo +getWalletInitInfo wKey@(wId, wdc) lock = do + -- Find all of the current UTXO that this wallet owns. + -- We lock the node state to be sure the tip header and the UTxO match + (tipHeader, curUtxo :: Map HD.HdAccountId (Utxo, [AddrWithId])) <- + fmap (second (fmap toPrefilteredUtxo . mergeUtxos)) $ + lock NotYetLocked $ \tip -> (tip, ) <$> filterUtxo isOurs + + -- Find genesis UTxO for this wallet + let genUtxo :: Map HD.HdAccountId (Utxo, [AddrWithId]) + genUtxo = fmap toPrefilteredUtxo . snd $ + prefilterUtxo' wKey (unGenesisUtxo genesisUtxo) + + -- Get the tip + mTip <- mostRecentMainBlock tipHeader + return $ case mTip of + Nothing -> WalletCreate genUtxo + Just tip -> WalletRestore (mergeInfo curUtxo genUtxo) (tipInfo tip) + where + tipInfo :: MainBlock -> (HeaderHash, SlotId) + tipInfo mb = (headerHash mb, mb ^. mainBlockSlot) + + mergeInfo :: (Monoid cur, Monoid gen) + => Map HD.HdAccountId (cur, [AddrWithId]) + -> Map HD.HdAccountId (gen, [AddrWithId]) + -> Map HD.HdAccountId (cur, gen, [AddrWithId]) + mergeInfo = M.merge + (M.mapMaybeMissing $ \_ (c, as) -> Just (c, mempty, as)) + (M.mapMaybeMissing $ \_ (g, as) -> Just (mempty, g, as)) + (M.zipWithMaybeMatched $ \_ (c, as) (g, as') -> Just (c, g, as ++ as')) + + mergeUtxos :: [(HD.HdAccountId, UtxoWithAddrId)] + -> Map HD.HdAccountId UtxoWithAddrId + mergeUtxos = M.fromListWith M.union + + isOurs :: (TxIn, TxOutAux) -> Maybe (HD.HdAccountId, UtxoWithAddrId) + isOurs (inp, out@(TxOutAux (TxOut addr _))) = do + wam <- decryptAddress wdc addr + let addrId = toHdAddressId wId wam + return (addrId ^. HD.hdAddressIdParent, M.singleton inp (out, addrId)) + +-- | Restore a wallet's transaction history. +-- +-- TODO: Think about what we should do if a 'RestorationException' is thrown. +restoreWalletHistoryAsync :: Kernel.PassiveWallet + -> HD.HdRootId + -> HeaderHash + -> SlotId + -> (Blund -> IO (Map HD.HdAccountId PrefilteredBlock, [TxMeta])) + -> IO () +restoreWalletHistoryAsync wallet rootId target tgtSlot prefilter = do + -- 'getFirstGenesisBlockHash' is confusingly named: it returns the hash of + -- the first block /after/ the genesis block. + startingPoint <- withNode $ getFirstGenesisBlockHash + restore startingPoint NoTimingData + where + wId :: WalletId + wId = WalletIdHdRnd rootId + + -- Process the restoration of the block with the given 'HeaderHash'. + restore :: HeaderHash -> TimingData -> IO () + restore hh timing = do + -- Updating the average rate every 5 blocks. + (rate, timing') <- tickTiming 5 timing + + -- Update each account's historical checkpoints + block <- getBlockOrThrow hh + + -- Skip EBBs + whenRight block $ \mb -> do + -- Filter the blocks by account + blund <- (Right mb, ) <$> getUndoOrThrow hh + (prefilteredBlocks, txMetas) <- prefilter blund + + -- Apply the block + k <- getSecurityParameter (wallet ^. walletNode) + ctxt <- withNode $ mainBlockContext mb + mErr <- update (wallet ^. wallets) $ + ApplyHistoricalBlock k ctxt prefilteredBlocks + case mErr of + Left err -> throwM $ RestorationApplyHistoricalBlockFailed err + Right () -> return () + + -- Update our progress + slotCount <- getSlotCount (wallet ^. walletNode) + let flat = flattenSlotIdExplicit slotCount + blockPerSec = MeasuredIn . BlockCount . perSecond <$> rate + throughputUpdate = maybe identity (set wriThroughput) blockPerSec + slotId = mb ^. mainBlockSlot + updateRestorationInfo wallet wId ( (wriCurrentSlot .~ flat slotId) + . (wriTargetSlot .~ flat tgtSlot) + . throughputUpdate ) + + -- Store the TxMetas + forM_ txMetas (putTxMeta (wallet ^. walletMeta)) + + -- Get the next block from the node and recurse. + if target == hh then + finish + else + nextBlock hh >>= \case + Nothing -> throwM $ RestorationFinishUnreachable target hh + Just header' -> restore header' timing' + + -- TODO (@mn): probably should use some kind of bracket to ensure this cleanup happens. + finish :: IO () + finish = do + k <- getSecurityParameter (wallet ^. walletNode) + update (wallet ^. wallets) $ RestorationComplete k rootId + modifyMVar_ (wallet ^. walletRestorationTask) (pure . M.delete wId) + + -- Step forward to the successor of the given block. + nextBlock :: HeaderHash -> IO (Maybe HeaderHash) + nextBlock hh = withNode (resolveForwardLink hh) + + -- Get a block + getBlockOrThrow :: HeaderHash -> IO Block + getBlockOrThrow hh = do + mBlock <- withNode $ getBlock hh + case mBlock of + Nothing -> throwM $ RestorationBlockNotFound hh + Just b -> return b + + -- Get undo for a mainblock + -- NOTE: We use this undo information only for input resolution. + getUndoOrThrow :: HeaderHash -> IO Undo + getUndoOrThrow hh = do + mBlock <- withNode $ getUndo hh + case mBlock of + Nothing -> throwM $ RestorationUndoNotFound hh + Just b -> return b + + withNode :: forall a. (NodeConstraints => WithNodeState IO a) -> IO a + withNode action = withNodeState (wallet ^. walletNode) (\_lock -> action) + +-- Update the restoration information for a wallet. +updateRestorationInfo :: Kernel.PassiveWallet + -> WalletId + -> (WalletRestorationInfo -> WalletRestorationInfo) + -> IO () +updateRestorationInfo wallet wId upd = + modifyMVar_ (wallet ^. walletRestorationTask) (pure . M.adjust upd wId) + +{------------------------------------------------------------------------------- + Timing information (for throughput calculations) +-------------------------------------------------------------------------------} + +-- | Keep track of how many events have happened since a given start time. +data TimingData + = NoTimingData + | Timing Integer UTCTime + +-- | A rate, represented as an event count over a time interval. +data Rate = Rate Integer NominalDiffTime + +-- | Log an event; once k' events have been seen, return the event rate +-- and start the count over again. +tickTiming :: Integer -> TimingData -> IO (Maybe Rate, TimingData) +tickTiming _ NoTimingData = (Nothing,) . Timing 0 <$> getCurrentTime +tickTiming k' (Timing k start) + | k == k' = do + now <- getCurrentTime + let rate = Rate k (now `diffUTCTime` start) + return (Just rate, Timing 0 now) + | otherwise = return (Nothing, Timing (k + 1) start) + +-- | Convert a rate to a number of events per second. +perSecond :: Rate -> Word64 +perSecond (Rate n dt) = fromInteger $ round (toRational n / toRational dt) + +{------------------------------------------------------------------------------- + Exceptions +-------------------------------------------------------------------------------} + +-- | Exception during restoration +data RestorationException = + RestorationBlockNotFound HeaderHash + | RestorationUndoNotFound HeaderHash + | RestorationApplyHistoricalBlockFailed Spec.ApplyBlockFailed + | RestorationFinishUnreachable HeaderHash HeaderHash + +instance Buildable RestorationException where + build (RestorationBlockNotFound hash) = + bprint ("RestorationBlockNotFound " % build) hash + build (RestorationUndoNotFound hash) = + bprint ("RestorationUndoNotFound " % build) hash + build (RestorationApplyHistoricalBlockFailed err) = + bprint ("RestorationApplyHistoricalBlockFailed " % build) err + build (RestorationFinishUnreachable target final) = + bprint ("RestorationFinishUnreachable " % build % " " % build) target final + +instance Show RestorationException where + show = formatToString build + +instance Exception RestorationException diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Types.hs b/wallet-new/src/Cardano/Wallet/Kernel/Types.hs index fac2f777ad6..5ca395b0a43 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Types.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Types.hs @@ -23,14 +23,14 @@ import Universum import qualified Data.List.NonEmpty as NE import Formatting.Buildable (Buildable (..)) -import Pos.Chain.Block (MainBlock, gbBody, mainBlockSlot, mbTxs, - mbWitnesses) +import Pos.Chain.Block (MainBlock, gbBody, mbTxs, mbWitnesses) import qualified Pos.Core as Core import Pos.Core.Txp (Tx, TxAux (..), TxId, TxIn (..), txInputs) import Formatting (bprint, (%)) import qualified Formatting as F +import Cardano.Wallet.Kernel.DB.BlockContext import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD import Cardano.Wallet.Kernel.DB.InDb import Cardano.Wallet.Kernel.DB.Resolved @@ -128,8 +128,12 @@ data RawResolvedBlock = UnsafeRawResolvedBlock { -- see 'fromRawResolvedBlock'. , rawResolvedBlockInputs :: !ResolvedBlockInputs - -- | The creation time of this Block. + -- | The creation time of this Block. + , rawTimestamp :: !Core.Timestamp + + -- | Block context + , rawResolvedContext :: !BlockContext } -- | Invariant for 'RawResolvedBlock' @@ -149,10 +153,11 @@ invRawResolvedBlock block ins = mkRawResolvedBlock :: MainBlock -> ResolvedBlockInputs -> Core.Timestamp + -> BlockContext -> RawResolvedBlock -mkRawResolvedBlock block ins timestamp = +mkRawResolvedBlock block ins timestamp context = if invRawResolvedBlock block ins - then UnsafeRawResolvedBlock block ins timestamp + then UnsafeRawResolvedBlock block ins timestamp context else error "mkRawResolvedBlock: invariant violation" {------------------------------------------------------------------------------- @@ -177,13 +182,12 @@ fromRawResolvedTx UnsafeRawResolvedTx{..} = ResolvedTx { fromRawResolvedBlock :: RawResolvedBlock -> ResolvedBlock fromRawResolvedBlock UnsafeRawResolvedBlock{..} = ResolvedBlock { - _rbTxs = zipWith aux (getBlockTxs rawResolvedBlock) - rawResolvedBlockInputs - , _rbSlotId = rawResolvedBlock ^. mainBlockSlot - , _rbMeta = rawTimestamp + _rbTxs = zipWith aux (getBlockTxs rawResolvedBlock) + rawResolvedBlockInputs + , _rbContext = rawResolvedContext + , _rbMeta = rawTimestamp } where - -- Justification for the use of the unsafe constructor: -- The invariant for 'RawResolvedBlock' guarantees the invariant for the -- individual transactions. diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Util/Core.hs b/wallet-new/src/Cardano/Wallet/Kernel/Util/Core.hs index 543b043763a..e64f1f0ea35 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Util/Core.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Util/Core.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} -- | Utility functions on core types -- -- Intended for qualified import diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Util/StrictList.hs b/wallet-new/src/Cardano/Wallet/Kernel/Util/StrictList.hs index 5db896089f1..913025eba3c 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Util/StrictList.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Util/StrictList.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} -- | Strict lists -- @@ -10,14 +11,20 @@ module Cardano.Wallet.Kernel.Util.StrictList ( , drop , dropWhile , toMaybe + , reverse + , last + , init + , splitLast + , toList ) where -import Universum hiding (drop, dropWhile, take) - -import Pos.Core.Chrono +import Universum hiding (drop, dropWhile, init, last, reverse, take, + toList) +import qualified Data.Foldable import Data.SafeCopy (SafeCopy (..), base, contain, deriveSafeCopy, safeGet, safePut) +import Pos.Core.Chrono data StrictList a = Nil | Cons !a !(StrictList a) deriving (Eq, Ord, Show, Functor) @@ -40,6 +47,17 @@ instance Monoid (StrictList a) where mempty = Nil mappend = (<>) +instance One (StrictList a) where + type OneItem (StrictList a) = a + one = singleton + +instance Foldable StrictList where + foldr e f = Data.Foldable.foldr e f . toList + +toList :: StrictList a -> [a] +toList Nil = [] +toList (Cons x xs) = x : toList xs + singleton :: a -> StrictList a singleton x = Cons x Nil @@ -62,3 +80,29 @@ dropWhile _ Nil = Nil toMaybe :: StrictList a -> Maybe a toMaybe Nil = Nothing toMaybe (Cons x _) = Just x + +reverse :: StrictList a -> StrictList a +reverse = go Nil + where + go :: StrictList a -> StrictList a -> StrictList a + go acc Nil = acc + go acc (Cons x xs) = go (Cons x acc) xs + +last :: StrictList a -> Maybe a +last = fmap snd . splitLast + +init :: StrictList a -> Maybe (StrictList a) +init = fmap fst . splitLast + +-- | Split off the last element +splitLast :: forall a. StrictList a -> Maybe (StrictList a, a) +splitLast = \case + Nil -> Nothing + Cons x xs -> Just $ go Nil x xs + where + go :: StrictList a -- Everything-but-the-last element seen so far + -> a -- The last element seen so far + -> StrictList a -- Elements not yet seen + -> (StrictList a, a) + go acc lastElem Nil = (reverse acc, lastElem) + go acc lastElem (Cons x xs) = go (Cons lastElem acc) x xs diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Util/StrictNonEmpty.hs b/wallet-new/src/Cardano/Wallet/Kernel/Util/StrictNonEmpty.hs index c8b06f5f8be..13f13fe0372 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Util/StrictNonEmpty.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Util/StrictNonEmpty.hs @@ -9,14 +9,19 @@ module Cardano.Wallet.Kernel.Util.StrictNonEmpty ( , head , (<|) , take + , last + , init + , splitLast + , prependList + , toList ) where -import Universum hiding ((:|), head, take) - -import Pos.Core.Chrono +import Universum hiding ((:|), head, init, last, take, toList) +import qualified Data.Foldable import Data.SafeCopy (SafeCopy (..), base, contain, deriveSafeCopy, safeGet, safePut) +import Pos.Core.Chrono import Cardano.Wallet.Kernel.Util.StrictList (StrictList) import qualified Cardano.Wallet.Kernel.Util.StrictList as SL @@ -37,12 +42,35 @@ deriveSafeCopy 1 'base ''StrictNonEmpty instance Semigroup (StrictNonEmpty a) where (x :| xs) <> (y :| ys) = x :| (xs <> (SL.Cons y ys)) +instance One (StrictNonEmpty a) where + type OneItem (StrictNonEmpty a) = a + one = singleton + +instance Foldable StrictNonEmpty where + foldr e f = Data.Foldable.foldr e f . toList + +toList :: StrictNonEmpty a -> [a] +toList (x :| xs) = x : SL.toList xs + singleton :: a -> StrictNonEmpty a singleton a = a :| mempty head :: Lens' (StrictNonEmpty a) a head f (x :| xs) = (\x' -> x' :| xs) <$> f x +init :: StrictNonEmpty a -> StrictList a +init = fst . splitLast + +last :: StrictNonEmpty a -> a +last = snd . splitLast + +-- | @splitLast ([a .. y] ++ [z]) = ([a .. y], z)@ +splitLast :: StrictNonEmpty a -> (StrictList a, a) +splitLast (x :| xs) = + case SL.splitLast xs of + Nothing -> (SL.Nil, x) + Just (xsInit, xsLast) -> (SL.Cons x xsInit, xsLast) + (<|) :: a -> StrictNonEmpty a -> StrictNonEmpty a x <| (x' :| xs) = x :| (SL.Cons x' xs) @@ -52,3 +80,7 @@ x <| (x' :| xs) = x :| (SL.Cons x' xs) take :: Int -> StrictNonEmpty a -> StrictNonEmpty a take 0 _ = error "StrictNonEmpty.take: cannot take 0" take k (x :| xs) = x :| SL.take (k - 1) xs + +prependList :: StrictList a -> StrictNonEmpty a -> StrictNonEmpty a +prependList SL.Nil ys = ys +prependList (SL.Cons x xs) (y :| ys) = x :| (xs <> SL.Cons y ys) diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Wallets.hs b/wallet-new/src/Cardano/Wallet/Kernel/Wallets.hs index d4103406837..8a98ddd0684 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Wallets.hs @@ -19,7 +19,6 @@ import qualified Formatting.Buildable import Data.Acid.Advanced (update') -import Pos.Chain.Txp (Utxo) import Pos.Core (Timestamp) import Pos.Crypto (EncryptedSecretKey, PassPhrase, changeEncPassphrase, checkPassMatches, emptyPassphrase, @@ -28,8 +27,8 @@ import Pos.Crypto (EncryptedSecretKey, PassPhrase, import Cardano.Wallet.Kernel.BIP39 (Mnemonic) import qualified Cardano.Wallet.Kernel.BIP39 as BIP39 import Cardano.Wallet.Kernel.DB.AcidState (CreateHdWallet (..), - DeleteHdRoot (..), UpdateHdRootPassword (..), - UpdateHdWallet (..)) + DeleteHdRoot (..), RestoreHdWallet, + UpdateHdRootPassword (..), UpdateHdWallet (..)) import Cardano.Wallet.Kernel.DB.HdWallet (AssuranceLevel, HdRoot, WalletName, eskToHdRootId) import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD @@ -38,7 +37,6 @@ import Cardano.Wallet.Kernel.DB.InDb (InDb (..)) import Cardano.Wallet.Kernel.Internal (PassiveWallet, walletKeystore, wallets) import qualified Cardano.Wallet.Kernel.Keystore as Keystore -import Cardano.Wallet.Kernel.PrefilterTx (prefilterUtxo) import qualified Cardano.Wallet.Kernel.Read as Kernel import Cardano.Wallet.Kernel.Types (WalletId (..)) import Cardano.Wallet.Kernel.Util.Core (getCurrentTimestamp) @@ -101,30 +99,29 @@ instance Exception UpdateWalletPasswordError -------------------------------------------------------------------------------} -- | Creates a new HD 'Wallet'. --- INVARIANT: The input 'Mnemonic' should be supplied by the frontend such that --- this is a brand new 'Mnemonic' never used before on the blockchain. Failing --- to do so would cause an invariant violation as we system would treat this --- wallet as a new one rather than dealing with a proper restoration. -- +-- PRECONDITION: The input 'Mnemonic' should be supplied by the frontend such +-- that this is a brand new 'Mnemonic' never used before on the blockchain. For +-- other wallets restoration should be used. createHdWallet :: PassiveWallet - -> Mnemonic nat - -- ^ The set of words (i.e the mnemonic) to generate the initial seed. - -- See - -- This Kernel function is agnostic in the number of words, and it's - -- wallet layer's responsibility to make sure that invalid sizes are - -- rejected. - -> PassPhrase - -- ^ The spending password to encrypt the 'SecretKey' for the - -- newly-generated wallet. If the user didn't specify any, the - -- empty 'PassPhrase' is used. - -> AssuranceLevel - -- ^ The 'AssuranceLevel' for this wallet, namely after how many - -- blocks each transaction is considered 'adopted'. This translates - -- in the frontend with a different threshold for the confirmation - -- range (@low@, @medium@, @high@). - -> WalletName - -- ^ The name for this wallet. - -> IO (Either CreateWalletError HdRoot) + -> Mnemonic nat + -- ^ The set of words (i.e the mnemonic) to generate the initial seed. + -- See + -- This Kernel function is agnostic in the number of words, and it's + -- wallet layer's responsibility to make sure that invalid sizes are + -- rejected. + -> PassPhrase + -- ^ The spending password to encrypt the 'SecretKey' for the + -- newly-generated wallet. If the user didn't specify any, the + -- empty 'PassPhrase' is used. + -> AssuranceLevel + -- ^ The 'AssuranceLevel' for this wallet, namely after how many + -- blocks each transaction is considered 'adopted'. This translates + -- in the frontend with a different threshold for the confirmation + -- range (@low@, @medium@, @high@). + -> WalletName + -- ^ The name for this wallet. + -> IO (Either CreateWalletError HdRoot) createHdWallet pw mnemonic spendingPassword assuranceLevel walletName = do -- STEP 1: Generate the 'EncryptedSecretKey' outside any acid-state -- transaction, to not leak it into acid-state's transaction logs. @@ -137,8 +134,9 @@ createHdWallet pw mnemonic spendingPassword assuranceLevel walletName = do walletName assuranceLevel esk - mempty -- Brand new wallets have no Utxo. - -- See the invariant at the top. + -- Brand new wallets have no Utxo + -- See preconditon above. + (\hdRoot -> Left $ CreateHdWallet hdRoot mempty) case res of Left e -> return . Left $ CreateWalletFailed e Right hdRoot -> do @@ -150,10 +148,6 @@ createHdWallet pw mnemonic spendingPassword assuranceLevel walletName = do -- | Creates an HD wallet where new accounts and addresses are generated -- via random index derivation. -- --- Prefilters the Utxo before passing it to the Acidstate update. --- --- Adds an HdRoot and HdAccounts (which are discovered during prefiltering of utxo). --- In the case of empty utxo, no HdAccounts are created. -- Fails with CreateHdWalletError if the HdRootId already exists. createWalletHdRnd :: PassiveWallet -> Bool @@ -161,9 +155,9 @@ createWalletHdRnd :: PassiveWallet -> HD.WalletName -> AssuranceLevel -> EncryptedSecretKey - -> Utxo + -> (HdRoot -> Either CreateHdWallet RestoreHdWallet) -> IO (Either HD.CreateHdRootError HdRoot) -createWalletHdRnd pw hasSpendingPassword name assuranceLevel esk utxo = do +createWalletHdRnd pw hasSpendingPassword name assuranceLevel esk createWallet = do created <- InDb <$> getCurrentTimestamp let rootId = eskToHdRootId esk newRoot = HD.initHdRoot rootId @@ -171,9 +165,10 @@ createWalletHdRnd pw hasSpendingPassword name assuranceLevel esk utxo = do (hdSpendingPassword created) assuranceLevel created - utxoByAccount = prefilterUtxo rootId esk utxo - res <- update' (pw ^. wallets) $ CreateHdWallet newRoot utxoByAccount + res <- case createWallet newRoot of + Left create -> update' (pw ^. wallets) create + Right restore -> update' (pw ^. wallets) restore return $ case res of Left err -> Left err Right () -> Right newRoot diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs index 89217aba47a..b312275129b 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -9,9 +10,8 @@ module Cardano.Wallet.WalletLayer.Kernel import Universum import qualified Control.Concurrent.STM as STM -import Data.Maybe (fromJust) -import Pos.Chain.Block (Blund, Undo (..), mainBlockSlot) +import Pos.Chain.Block (Blund) import qualified Pos.Core as Core import Pos.Core.Chrono (OldestFirst (..)) import Pos.Util.Wlog (Severity (Debug)) @@ -19,14 +19,10 @@ import Pos.Util.Wlog (Severity (Debug)) import qualified Cardano.Wallet.Kernel as Kernel import qualified Cardano.Wallet.Kernel.Actions as Actions import qualified Cardano.Wallet.Kernel.BListener as Kernel -import Cardano.Wallet.Kernel.DB.Resolved (ResolvedBlock) import Cardano.Wallet.Kernel.Diffusion (WalletDiffusion (..)) import Cardano.Wallet.Kernel.Keystore (Keystore) import Cardano.Wallet.Kernel.NodeStateAdaptor import qualified Cardano.Wallet.Kernel.Read as Kernel -import Cardano.Wallet.Kernel.Types (RawResolvedBlock (..), - fromRawResolvedBlock) -import Cardano.Wallet.Kernel.Util.Core (getCurrentTimestamp) import Cardano.Wallet.WalletLayer (ActiveWalletLayer (..), PassiveWalletLayer (..)) import qualified Cardano.Wallet.WalletLayer.Kernel.Accounts as Accounts @@ -46,26 +42,21 @@ bracketPassiveWallet -> Keystore -> NodeStateAdaptor IO -> (PassiveWalletLayer n -> Kernel.PassiveWallet -> m a) -> m a -bracketPassiveWallet logFunction keystore rocksDB f = do - Kernel.bracketPassiveWallet logFunction keystore rocksDB $ \w -> do +bracketPassiveWallet logFunction keystore node f = do + Kernel.bracketPassiveWallet logFunction keystore node $ \w -> do let wai = Actions.WalletActionInterp { Actions.applyBlocks = \blunds -> do - ls <- mapM (blundToResolvedBlock getTime) + ls <- mapM (Wallets.blundToResolvedBlock node) (toList (getOldestFirst blunds)) let mp = catMaybes ls - Kernel.applyBlocks w (OldestFirst mp) + -- TODO: Deal with ApplyBlockFailed + mapM_ (Kernel.applyBlock w) mp , Actions.switchToFork = \_ _ -> logFunction Debug "" , Actions.emit = logFunction Debug } Actions.withWalletWorker wai $ \invoke -> do f (passiveWalletLayer w invoke) w where - getTime :: Core.SlotId -> IO Core.Timestamp - getTime n = do - time <- rightToMaybe <$> getSlotStart rocksDB n - defaultTime <- getCurrentTimestamp - return $ fromMaybe defaultTime time - passiveWalletLayer :: Kernel.PassiveWallet -> (Actions.WalletAction Blund -> STM ()) -> PassiveWalletLayer n @@ -87,8 +78,8 @@ bracketPassiveWallet logFunction keystore rocksDB f = do , rollbackBlocks = invokeIO . Actions.RollbackBlocks . length -- Read-only operations - , getWallets = ro $ Wallets.getWallets - , getWallet = \wId -> ro $ Wallets.getWallet wId + , getWallets = join (ro $ Wallets.getWallets w) + , getWallet = \wId -> join (ro $ Wallets.getWallet w wId) , getUtxos = \wId -> ro $ Wallets.getWalletUtxos wId , getAccounts = \wId -> ro $ Accounts.getAccounts wId , getAccount = \wId acc -> ro $ Accounts.getAccount wId acc @@ -108,21 +99,6 @@ bracketPassiveWallet logFunction keystore rocksDB f = do invokeIO :: forall m'. MonadIO m' => Actions.WalletAction Blund -> m' () invokeIO = liftIO . STM.atomically . invoke - - -- The use of the unsafe constructor 'UnsafeRawResolvedBlock' is justified - -- by the invariants established in the 'Blund'. - blundToResolvedBlock :: (Core.SlotId -> IO Core.Timestamp) -> Blund -> IO (Maybe ResolvedBlock) - blundToResolvedBlock getTimeBySlot (b,u) = do - case b of - Left _ -> return Nothing - Right mainBlock -> do - let slot = mainBlock ^. mainBlockSlot - time <- getTimeBySlot slot - return . Just $ fromRawResolvedBlock - (UnsafeRawResolvedBlock mainBlock spentOutputs' time) - where - spentOutputs' = map (map fromJust) $ undoTx u - -- | Initialize the active wallet. -- The active wallet is allowed to send transactions, as it has the full -- 'WalletDiffusion' layer in scope. diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Conv.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Conv.hs index 3a9ca388932..ea5b848ad67 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Conv.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Conv.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} -- | Convert to and from V1 types module Cardano.Wallet.WalletLayer.Kernel.Conv ( -- * From V1 to kernel types @@ -13,6 +14,7 @@ module Cardano.Wallet.WalletLayer.Kernel.Conv ( , toWallet , toAddress , toAssuranceLevel + , toSyncState -- * Custom errors , InvalidRedemptionCode(..) -- * Convenience re-exports @@ -34,10 +36,11 @@ import Formatting (bprint, build, formatToString, sformat, shown, (%)) import qualified Formatting.Buildable import qualified Serokell.Util.Base64 as B64 -import Pos.Core (decodeTextAddress) +import Pos.Core (BlockCount (..), decodeTextAddress) import Pos.Crypto (AesKey, RedeemSecretKey, aesDecrypt, redeemDeterministicKeyGen) +import Cardano.Wallet.API.Types.UnitOfMeasure import Cardano.Wallet.API.V1.Types (V1 (..)) import qualified Cardano.Wallet.API.V1.Types as V1 import Cardano.Wallet.Kernel.BIP39 (mnemonicToAesKey) @@ -49,6 +52,8 @@ import Cardano.Wallet.Kernel.DB.Spec (cpAddressMeta) import Cardano.Wallet.Kernel.DB.Spec.Read import Cardano.Wallet.Kernel.DB.Util.IxSet (ixedIndexed) import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet +import Cardano.Wallet.Kernel.Internal (WalletRestorationInfo, + wriCurrentSlot, wriTargetSlot, wriThroughput) import qualified Cardano.Wallet.Kernel.Read as Kernel import Cardano.Wallet.Kernel.Util (exceptT) -- import Cardano.Wallet.WalletLayer (InvalidRedemptionCode (..)) @@ -158,7 +163,6 @@ toWallet db hdRoot = V1.Wallet { , walSpendingPasswordLastUpdate = V1 lastUpdate , walCreatedAt = V1 createdAt , walAssuranceLevel = v1AssuranceLevel - -- FIXME(adn) Do this as part of CBR-243. , walSyncState = V1.Synced -- FIXME: Now we have 2 types of wallet: regular and external. -- Currently there's only regular wallets, it will be changed in @@ -224,3 +228,23 @@ instance Buildable InvalidRedemptionCode where instance Show InvalidRedemptionCode where show = formatToString build + +-- | Calculate the 'SyncState' from data about the wallet's restoration. +toSyncState :: Maybe WalletRestorationInfo -> V1.SyncState +toSyncState = \case + Nothing -> V1.Synced + Just info -> let MeasuredIn (BlockCount blocksPerSec) = info ^. wriThroughput + in V1.Restoring $ + V1.SyncProgress + { spEstimatedCompletionTime = + let blocksToGo = (info ^. wriTargetSlot) - (info ^. wriCurrentSlot) + bps = max blocksPerSec 1 + in V1.mkEstimatedCompletionTime (fromIntegral ((1000 * blocksToGo) `div` bps)) + , spThroughput = V1.mkSyncThroughput (BlockCount blocksPerSec) + , spPercentage = + let tgtSlot = info ^. wriTargetSlot + pct = if tgtSlot /= 0 + then (100 * (info ^. wriCurrentSlot)) `div` tgtSlot + else 0 + in V1.mkSyncPercentage (fromIntegral pct) + } diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs index a5f16f7f77e..adbe1c10115 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module Cardano.Wallet.WalletLayer.Kernel.Wallets ( createWallet , updateWallet @@ -6,12 +7,16 @@ module Cardano.Wallet.WalletLayer.Kernel.Wallets ( , getWallet , getWallets , getWalletUtxos + , blundToResolvedBlock ) where import Universum import Data.Coerce (coerce) +import qualified Data.Map as M +import Data.Maybe (fromJust) +import Pos.Chain.Block (Blund, mainBlockSlot, undoTx) import Pos.Chain.Txp (Utxo) import Pos.Core (mkCoin) import Pos.Core.Slotting (Timestamp) @@ -20,14 +25,27 @@ import Pos.Crypto.Signing import Cardano.Wallet.API.V1.Types (V1 (..)) import qualified Cardano.Wallet.API.V1.Types as V1 import qualified Cardano.Wallet.Kernel.Accounts as Kernel +import qualified Cardano.Wallet.Kernel.BIP39 as BIP39 import Cardano.Wallet.Kernel.DB.AcidState (dbHdWallets) +import Cardano.Wallet.Kernel.DB.BlockContext import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD import Cardano.Wallet.Kernel.DB.InDb (fromDb) +import Cardano.Wallet.Kernel.DB.Resolved (ResolvedBlock) +import Cardano.Wallet.Kernel.DB.TxMeta.Types import Cardano.Wallet.Kernel.DB.Util.IxSet (IxSet) import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet +import Cardano.Wallet.Kernel.Internal (walletKeystore, + walletRestorationTask) import qualified Cardano.Wallet.Kernel.Internal as Kernel +import qualified Cardano.Wallet.Kernel.Keystore as Keystore +import Cardano.Wallet.Kernel.NodeStateAdaptor (NodeStateAdaptor) +import qualified Cardano.Wallet.Kernel.NodeStateAdaptor as Node +import Cardano.Wallet.Kernel.PrefilterTx (PrefilteredBlock, + prefilterBlock) import qualified Cardano.Wallet.Kernel.Read as Kernel -import Cardano.Wallet.Kernel.Types (WalletId (..)) +import Cardano.Wallet.Kernel.Restore (restoreWallet) +import Cardano.Wallet.Kernel.Types (RawResolvedBlock (..), + WalletId (..), fromRawResolvedBlock) import Cardano.Wallet.Kernel.Util.Core (getCurrentTimestamp) import qualified Cardano.Wallet.Kernel.Wallets as Kernel import Cardano.Wallet.WalletLayer (CreateWalletError (..), @@ -48,7 +66,7 @@ createWallet wallet v1WalletName operation) = liftIO $ do case operation of - V1.RestoreWallet -> error "Not implemented, see [CBR-243]." + V1.RestoreWallet -> restore V1.CreateWallet -> create where create :: IO (Either CreateWalletError V1.Wallet) @@ -61,15 +79,48 @@ createWallet wallet hdAssuranceLevel (HD.WalletName v1WalletName) let rootId = root ^. HD.hdRootId - fmap (mkRoot now root) $ - withExceptT CreateWalletFirstAccountCreationFailed $ ExceptT $ - Kernel.createAccount spendingPassword - (HD.AccountName "Default account") - (WalletIdHdRnd rootId) - wallet - - mkRoot :: Timestamp -> HD.HdRoot -> HD.HdAccount -> V1.Wallet - mkRoot now hdRoot _acc = V1.Wallet { + _ <- withExceptT CreateWalletFirstAccountCreationFailed $ ExceptT $ + Kernel.createAccount spendingPassword + (HD.AccountName "Default account") + (WalletIdHdRnd rootId) + wallet + return (mkRoot now root) + + restore :: IO (Either CreateWalletError V1.Wallet) + restore = runExceptT $ do + now <- liftIO getCurrentTimestamp + + let esk = snd $ safeDeterministicKeyGen + (BIP39.mnemonicToSeed mnemonic) + spendingPassword + rootId = HD.eskToHdRootId esk + wId = WalletIdHdRnd rootId + + -- Insert the 'EncryptedSecretKey' into the 'Keystore' + liftIO $ Keystore.insert wId esk (wallet ^. walletKeystore) + + -- Synchronously restore the wallet balance, and begin to + -- asynchronously reconstruct the wallet's history. + let prefilter :: Blund -> IO (Map HD.HdAccountId PrefilteredBlock, [TxMeta]) + prefilter blund = + blundToResolvedBlock (wallet ^. Kernel.walletNode) blund <&> \case + Nothing -> (M.empty, []) + Just rb -> prefilterBlock rb wId esk + + (root, coins) <- withExceptT (CreateWalletError . Kernel.CreateWalletFailed) $ ExceptT $ + restoreWallet + wallet + (spendingPassword /= emptyPassphrase) + (HD.WalletName v1WalletName) + hdAssuranceLevel + esk + prefilter + + -- Return the wallet information, with an updated balance. + updateSyncState wallet wId ((mkRoot now root) { V1.walBalance = V1 coins }) + + mkRoot :: Timestamp -> HD.HdRoot -> V1.Wallet + mkRoot now hdRoot = V1.Wallet { walId = walletId , walName = v1WalletName , walBalance = V1 (mkCoin 0) @@ -100,9 +151,10 @@ updateWallet :: MonadIO m -> m (Either UpdateWalletError V1.Wallet) updateWallet wallet wId (V1.WalletUpdate v1Level v1Name) = runExceptT $ do rootId <- withExceptT UpdateWalletWalletIdDecodingFailed $ fromRootId wId - fmap (uncurry toWallet) $ - withExceptT (UpdateWalletError . V1) $ ExceptT $ liftIO $ - Kernel.updateHdWallet wallet rootId newLevel newName + v1wal <- fmap (uncurry toWallet) $ + withExceptT (UpdateWalletError . V1) $ ExceptT $ liftIO $ + Kernel.updateHdWallet wallet rootId newLevel newName + updateSyncState wallet (WalletIdHdRnd rootId) v1wal where newLevel = fromAssuranceLevel v1Level newName = HD.WalletName v1Name @@ -120,9 +172,10 @@ updateWalletPassword wallet (V1 newPwd)) = runExceptT $ do rootId <- withExceptT UpdateWalletPasswordWalletIdDecodingFailed $ fromRootId wId - fmap (uncurry toWallet) $ - withExceptT UpdateWalletPasswordError $ ExceptT $ liftIO $ - Kernel.updatePassword wallet rootId oldPwd newPwd + v1wal <- fmap (uncurry toWallet) $ + withExceptT UpdateWalletPasswordError $ ExceptT $ liftIO $ + Kernel.updatePassword wallet rootId oldPwd newPwd + updateSyncState wallet (WalletIdHdRnd rootId) v1wal -- | Updates the 'SpendingPassword' for this wallet. deleteWallet :: MonadIO m @@ -135,20 +188,32 @@ deleteWallet wallet wId = runExceptT $ do Kernel.deleteHdWallet wallet rootId -- | Gets a specific wallet. -getWallet :: V1.WalletId +getWallet :: MonadIO m + => Kernel.PassiveWallet + -> V1.WalletId -> Kernel.DB - -> Either GetWalletError V1.Wallet -getWallet wId db = runExcept $ do - rootId <- withExceptT GetWalletWalletIdDecodingFailed $ fromRootId wId - fmap (toWallet db) $ - withExceptT (GetWalletError . V1) $ exceptT $ - Kernel.lookupHdRootId db rootId + -> m (Either GetWalletError V1.Wallet) +getWallet wallet wId db = runExceptT $ do + rootId <- withExceptT GetWalletWalletIdDecodingFailed (fromRootId wId) + v1wal <- fmap (toWallet db) $ + withExceptT (GetWalletError . V1) $ exceptT $ + Kernel.lookupHdRootId db rootId + updateSyncState wallet (WalletIdHdRnd rootId) v1wal -- | Gets all the wallets known to this edge node. -- +-- NOTE: The wallet sync state is not set here; use 'updateSyncState' to +-- get a correct result. +-- -- TODO: Avoid IxSet creation [CBR-347]. -getWallets :: Kernel.DB -> IxSet V1.Wallet -getWallets db = IxSet.fromList . map (toWallet db) . IxSet.toList $ allRoots +getWallets :: MonadIO m + => Kernel.PassiveWallet + -> Kernel.DB + -> m (IxSet V1.Wallet) +getWallets wallet db = + fmap IxSet.fromList $ forM (IxSet.toList allRoots) $ \root -> do + let rootId = root ^. HD.hdRootId + updateSyncState wallet (WalletIdHdRnd rootId) (toWallet db root) where allRoots = db ^. dbHdWallets . HD.hdWalletsRoots @@ -171,3 +236,29 @@ getWalletUtxos wId db = runExcept $ do withExceptT GetUtxosCurrentAvailableUtxoError $ exceptT $ do utxo <- Kernel.currentAvailableUtxo db (account ^. HD.hdAccountId) return (toAccount db account, utxo) + +-- | The use of the unsafe constructor 'UnsafeRawResolvedBlock' is justified +-- by the invariants established in the 'Blund'. +blundToResolvedBlock :: NodeStateAdaptor IO -> Blund -> IO (Maybe ResolvedBlock) +blundToResolvedBlock node (b,u) = do + case b of + Left _ebb -> return Nothing + Right mainBlock -> Node.withNodeState node $ \_lock -> do + ctxt <- mainBlockContext mainBlock + mTime <- Node.defaultGetSlotStart (mainBlock ^. mainBlockSlot) + now <- liftIO $ getCurrentTimestamp + return $ Just $ fromRawResolvedBlock UnsafeRawResolvedBlock { + rawResolvedBlock = mainBlock + , rawResolvedBlockInputs = map (map fromJust) $ undoTx u + , rawTimestamp = either (const now) identity mTime + , rawResolvedContext = ctxt + } + +updateSyncState :: MonadIO m + => Kernel.PassiveWallet + -> WalletId + -> V1.Wallet + -> m V1.Wallet +updateSyncState wallet wId v1wal = do + wss <- M.lookup wId <$> readMVar (wallet ^. walletRestorationTask) + return v1wal { V1.walSyncState = toSyncState wss } diff --git a/wallet-new/test/unit/UTxO/Interpreter.hs b/wallet-new/test/unit/UTxO/Interpreter.hs index 231dd699508..dc4f66e2ce8 100644 --- a/wallet-new/test/unit/UTxO/Interpreter.hs +++ b/wallet-new/test/unit/UTxO/Interpreter.hs @@ -42,6 +42,7 @@ import qualified Formatting.Buildable import Prelude (Show (..)) import Serokell.Util (listJson, mapJson) +import Cardano.Wallet.Kernel.DB.BlockContext import Cardano.Wallet.Kernel.DB.BlockMeta (AddressMeta, BlockMeta (..)) import Cardano.Wallet.Kernel.DB.InDb @@ -50,7 +51,8 @@ import Cardano.Wallet.Kernel.Types import Cardano.Wallet.Kernel.Util (at) import Pos.Chain.Block (Block, BlockHeader (..), GenesisBlock, - MainBlock, gbHeader, genBlockLeaders, mkGenesisBlock) + HeaderHash, MainBlock, gbHeader, genBlockLeaders, + headerHash, mkGenesisBlock) import Pos.Chain.Lrc (followTheSatoshi) import Pos.Chain.Ssc (defaultSscPayload) import Pos.Chain.Txp (Utxo, txOutStake) @@ -138,6 +140,14 @@ data IntCheckpoint = IntCheckpoint { -- Will be initialized to the header of the genesis block. , icBlockHeader :: !BlockHeader + -- | The header of the /main/ block in this slot + -- + -- This may be different at epoch boundaries, when 'icBlockHeader' will + -- be set to the header of the EBB. + -- + -- Set to 'Nothing' for the first checkpoint. + , icMainBlockHdr :: !(Maybe HeaderHash) + -- | Slot leaders for the current epoch , icEpochLeaders :: !SlotLeaders @@ -178,6 +188,7 @@ initIntCtxt boot = do , _icCheckpoints = IntCheckpoint { icSlotId = translateFirstSlot , icBlockHeader = genesis + , icMainBlockHdr = Nothing , icEpochLeaders = leaders , icStakes = initStakes , icCrucialStakes = initStakes @@ -337,10 +348,9 @@ pushCheckpoint f = do mkCheckpoint :: Monad m => IntCheckpoint -- ^ Previous checkpoint - -> SlotId -- ^ Slot of the new block just created -> RawResolvedBlock -- ^ The block just created -> TranslateT IntException m IntCheckpoint -mkCheckpoint prev slot raw@(UnsafeRawResolvedBlock block _inputs _) = do +mkCheckpoint prev raw@(UnsafeRawResolvedBlock block _inputs _ ctxt) = do pc <- asks constants gs <- asks weights let isCrucial = give pc $ slot == crucialSlot (siEpoch slot) @@ -348,12 +358,15 @@ mkCheckpoint prev slot raw@(UnsafeRawResolvedBlock block _inputs _) = do return IntCheckpoint { icSlotId = slot , icBlockHeader = BlockHeaderMain $ block ^. gbHeader + , icMainBlockHdr = Just $ headerHash block , icEpochLeaders = icEpochLeaders prev , icStakes = newStakes , icCrucialStakes = if isCrucial then newStakes else icCrucialStakes prev } + where + slot = ctxt ^. bcSlotId . fromDb -- | Update the stakes map as a result of a block. -- @@ -634,8 +647,13 @@ instance DSL.Hash h Addr => Interpret h (DSL.Block h Addr) where slot txs' let currentTime = getSomeTimestamp - let raw = mkRawResolvedBlock block resolvedTxInputs currentTime - checkpoint <- mkCheckpoint prev slot raw + let ctxt = BlockContext { + _bcSlotId = InDb $ slot + , _bcHash = InDb $ headerHash block + , _bcPrevMain = InDb <$> icMainBlockHdr prev + } + let raw = mkRawResolvedBlock block resolvedTxInputs currentTime ctxt + checkpoint <- mkCheckpoint prev raw if isEpochBoundary pc slot then second (\ebb -> (raw, Just ebb)) <$> createEpochBoundary checkpoint else return (checkpoint, (raw, Nothing)) diff --git a/wallet-new/test/unit/Wallet/Inductive/Cardano.hs b/wallet-new/test/unit/Wallet/Inductive/Cardano.hs index 633fad3d19b..b15410d6f09 100644 --- a/wallet-new/test/unit/Wallet/Inductive/Cardano.hs +++ b/wallet-new/test/unit/Wallet/Inductive/Cardano.hs @@ -28,6 +28,7 @@ import Pos.Core.Chrono import Pos.Crypto (EncryptedSecretKey) import qualified Cardano.Wallet.Kernel.BListener as Kernel +import qualified Cardano.Wallet.Kernel.DB.AcidState as DB import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD import qualified Cardano.Wallet.Kernel.Internal as Internal import Cardano.Wallet.Kernel.Invariants as Kernel @@ -216,12 +217,14 @@ equivalentT useWW activeWallet esk = \mkWallet w -> -> Utxo -> TranslateT EquivalenceViolation m HD.HdAccountId walletBootT ctxt utxo = do - res <- liftIO $ Kernel.createWalletHdRnd passiveWallet - False - walletName - assuranceLevel - esk - utxo + res <- liftIO $ + Kernel.createWalletHdRnd + passiveWallet + False + walletName + assuranceLevel + esk + (\root -> Left $ DB.CreateHdWallet root (prefilterUtxo (root ^. HD.hdRootId) esk utxo)) case res of Left e -> createWalletErr (STB e) Right hdRoot -> do @@ -260,7 +263,8 @@ equivalentT useWW activeWallet esk = \mkWallet w -> -> RawResolvedBlock -> TranslateT EquivalenceViolation m () walletApplyBlockT ctxt accountId block = do - liftIO $ Kernel.applyBlock passiveWallet (fromRawResolvedBlock block) + -- We assume the wallet is not behind + Right () <- liftIO $ Kernel.applyBlock passiveWallet (fromRawResolvedBlock block) checkWalletState ctxt accountId walletNewPendingT :: InductiveCtxt h