Minimal Viable Wallet Layer #43
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,240 @@ | ||
| {-# LANGUAGE BangPatterns #-} | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE GADTs #-} | ||
| {-# LANGUAGE RankNTypes #-} | ||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
| {-# LANGUAGE StandaloneDeriving #-} | ||
| {-# LANGUAGE TypeOperators #-} | ||
|
|
||
| -- | | ||
| -- Copyright: © 2018-2019 IOHK | ||
| -- License: MIT | ||
| -- | ||
| -- Here we find the "business logic" to manage a Cardano wallet. This is a | ||
| -- direct implementation of the model from the [Formal Specification for a Cardano Wallet](https://github.com/input-output-hk/cardano-wallet/blob/master/specifications/wallet/formal-specification-for-a-cardano-wallet.pdf) | ||
|
There was a problem hiding this comment. don't we want to split it into two lines? There was a problem hiding this comment. I wish but we can't split the link :( |
||
| -- Note that, this module is purposedly agnostic to how blocks are retrieved or | ||
| -- how various types are serialized. | ||
| -- | ||
| -- This is really about how the wallet keep track of its internal state, and its | ||
| -- UTxO (where the relationship is defined via the 'IsOurs' abstraction to allow | ||
| -- this core code to be used with any sort of derivation scheme). | ||
| -- | ||
| -- All those functions are pure and there's no reason to shove in any sort of | ||
| -- side-effects in here :) | ||
|
|
||
| module Cardano.Wallet | ||
| ( | ||
| -- * Wallet | ||
| Wallet | ||
| , initWallet | ||
| , applyBlock | ||
| , availableBalance | ||
| , totalBalance | ||
| , totalUTxO | ||
| , availableUTxO | ||
|
|
||
| -- * Helpers | ||
| , invariant | ||
| , txOutsOurs | ||
| , utxoFromTx | ||
| ) where | ||
|
|
||
| import Prelude | ||
|
|
||
| import Cardano.Wallet.Binary | ||
| ( txId ) | ||
| import Cardano.Wallet.Primitive | ||
| ( Block (..) | ||
| , Dom (..) | ||
| , IsOurs (..) | ||
| , Tx (..) | ||
| , TxIn (..) | ||
| , TxOut (..) | ||
| , UTxO (..) | ||
| , balance | ||
| , excluding | ||
| , restrictedBy | ||
| , restrictedTo | ||
| , txIns | ||
| , updatePending | ||
| ) | ||
| import Control.DeepSeq | ||
| ( NFData (..), deepseq ) | ||
| import Control.Monad.Trans.State.Strict | ||
| ( State, runState, state ) | ||
| import Data.List.NonEmpty | ||
| ( NonEmpty (..) ) | ||
| import Data.Maybe | ||
| ( catMaybes ) | ||
| import Data.Set | ||
| ( Set ) | ||
| import Data.Traversable | ||
| ( for ) | ||
|
|
||
| import qualified Data.Map as Map | ||
| import qualified Data.Set as Set | ||
|
|
||
|
|
||
| -- * Wallet | ||
|
|
||
| -- | An opaque wallet type, see @initWallet@ and @applyBlock@ to construct and | ||
| -- update wallets. | ||
| -- | ||
| -- Internally, this keeps track or a few things including: | ||
| -- | ||
| -- - UTxOs | ||
| -- - Pending transaction | ||
| -- - TODO: Transaction history | ||
| -- - TODO: Known & used addresses | ||
| data Wallet s where | ||
| Wallet | ||
| :: (IsOurs s, Semigroup s, NFData s, Show s) | ||
| => UTxO | ||
| -> Set Tx | ||
| -> s | ||
| -> Wallet s | ||
|
|
||
| deriving instance Show (Wallet s) | ||
|
|
||
| instance NFData (Wallet s) where | ||
| rnf (Wallet utxo pending s) = | ||
| rnf utxo `deepseq` (rnf pending `deepseq` (rnf s `deepseq` ())) | ||
|
|
||
|
|
||
| -- | Create an empty wallet from an initial state | ||
| initWallet | ||
| :: (IsOurs s, Semigroup s, NFData s, Show s) | ||
| => s | ||
| -> Wallet s | ||
| initWallet = Wallet mempty mempty | ||
|
|
||
|
|
||
| -- | Apply Block is the only way to make the wallet evolve. | ||
| applyBlock | ||
| :: Block | ||
| -> NonEmpty (Wallet s) | ||
| -> NonEmpty (Wallet s) | ||
| applyBlock !b (cp@(Wallet !utxo !pending _) :| checkpoints) = | ||
| let | ||
| (ourUtxo, ourIns, s') = prefilterBlock b cp | ||
| utxo' = (utxo <> ourUtxo) `excluding` ourIns | ||
| pending' = updatePending b pending | ||
| cp' = Wallet utxo' pending' s' | ||
| in | ||
| -- NOTE | ||
| -- k = 2160 is currently hard-coded here. In the short-long run, we do | ||
| -- want to get that as an argument or, leave that decision to the caller | ||
| -- though it is not trivial at all. If it shrinks, it's okay because we | ||
| -- have enough checkpoints, but if it does increase, then we have | ||
|
There was a problem hiding this comment. you mean the problematic situation would be: the caller has an ability to set k in applyBlocks? and the wallet persists the state and then is called with higher k at some point, and for some period it misses checkpoints to be compliant with new k parameter. And then rollback comes that has depth covering those missing checkpoints? Maybe in that case k->k' , where k'>k some kind of "restotration" should take place to compensate it.... There was a problem hiding this comment. That's what I meant yes. So, there are different way to deal with this indeed, but it's not trivial, hence the warning. |
||
| -- problems in case of rollbacks. | ||
| (cp' :| cp : take 2160 checkpoints) | ||
|
|
||
|
|
||
| -- | Available balance = 'balance' . 'availableUTxO' | ||
| availableBalance :: Wallet s -> Integer | ||
| availableBalance = | ||
| balance . availableUTxO | ||
|
|
||
|
|
||
| -- | Total balance = 'balance' . 'totalUTxO' | ||
| totalBalance :: Wallet s -> Integer | ||
| totalBalance = | ||
| balance . totalUTxO | ||
|
|
||
|
|
||
| -- | Available UTxO = UTxO that aren't part of pending txs | ||
| availableUTxO :: Wallet s -> UTxO | ||
| availableUTxO (Wallet utxo pending _) = | ||
| utxo `excluding` txIns pending | ||
|
|
||
|
|
||
| -- | Total UTxO = 'availableUTxO' <> "pending UTxO" | ||
| totalUTxO :: Wallet s -> UTxO | ||
| totalUTxO wallet@(Wallet _ pending s) = | ||
| let | ||
| -- NOTE | ||
| -- We _safely_ discard the state here because we aren't intending to | ||
| -- discover any new addresses through this operation. In practice, we | ||
| -- can only discover new addresses when applying blocks. | ||
| discardState = fst | ||
| in | ||
| availableUTxO wallet <> discardState (changeUTxO pending s) | ||
|
|
||
|
|
||
| -- * Helpers | ||
|
|
||
| -- | Check whether an invariants holds or not. | ||
| -- | ||
| -- >>> invariant "not empty" [1,2,3] (not . null) | ||
| -- [1, 2, 3] | ||
| -- | ||
| -- >>> invariant "not empty" [] (not . null) | ||
| -- *** Exception: not empty | ||
| invariant | ||
| :: String -- ^ A title / message to throw in case of violation | ||
| -> a | ||
| -> (a -> Bool) | ||
| -> a | ||
| invariant msg a predicate = | ||
| if predicate a then a else error msg | ||
|
|
||
| -- | Return all transaction outputs that are ours. This plays well within a | ||
| -- 'State' monad. | ||
| -- | ||
| -- @ | ||
| -- myFunction :: Block -> State s Result | ||
| -- myFunction b = do | ||
| -- ours <- state $ txOutsOurs (transaction b) | ||
| -- return $ someComputation ours | ||
| -- @ | ||
| txOutsOurs | ||
| :: forall s. (IsOurs s) | ||
| => Set Tx | ||
| -> s | ||
| -> (Set TxOut, s) | ||
| txOutsOurs txs = | ||
| runState $ Set.fromList <$> forMaybe (foldMap outputs txs) pick | ||
| where | ||
| pick :: TxOut -> State s (Maybe TxOut) | ||
| pick out = do | ||
| predicate <- state $ isOurs (address out) | ||
| return $ if predicate then Just out else Nothing | ||
|
|
||
| forMaybe :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b] | ||
| forMaybe xs = fmap catMaybes . for xs | ||
|
|
||
| -- | Construct a UTxO corresponding to a given transaction. It is important for | ||
| -- the transaction outputs to be ordered correctly, since they become available | ||
| -- inputs for the subsequent blocks. | ||
| utxoFromTx :: Tx -> UTxO | ||
| utxoFromTx tx@(Tx _ outs) = | ||
| UTxO $ Map.fromList $ zip (TxIn (txId tx) <$> [0..]) outs | ||
|
|
||
|
|
||
| -- * Internals | ||
|
|
||
| prefilterBlock | ||
| :: Block | ||
| -> Wallet s | ||
| -> (UTxO, Set TxIn, s) | ||
| prefilterBlock b (Wallet !utxo _ !s) = | ||
| let | ||
| txs = transactions b | ||
| (ourOuts, s') = txOutsOurs txs s | ||
|
There was a problem hiding this comment. in the previous code prefiltering acted on the whole set of transactions. now we make sure we intersect only on those belonging to us. Nice! |
||
| ourUtxo = foldMap utxoFromTx txs `restrictedTo` ourOuts | ||
| ourIns = txIns txs `Set.intersection` dom (utxo <> ourUtxo) | ||
| in | ||
| invariant "applyBlock requires: dom ourUtxo ∩ dom utxo = ∅" | ||
| (ourUtxo, ourIns, s') | ||
| (const $ Set.null $ dom ourUtxo `Set.intersection` dom utxo) | ||
|
|
||
| changeUTxO | ||
| :: IsOurs s | ||
| => Set Tx | ||
| -> s | ||
| -> (UTxO, s) | ||
| changeUTxO pending = runState $ do | ||
| ours <- state $ txOutsOurs pending | ||
| let utxo = foldMap utxoFromTx pending | ||
| let ins = txIns pending | ||
| return $ (utxo `restrictedTo` ours) `restrictedBy` ins | ||
Oops, something went wrong.
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
I bet there are some strong argument in favor of using fmt vs formatting?
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
There are some arguments. See #sl-core (I'll send you a link in PM)