Merge pull request #3245 from input-output-hk/feature/cbr-150-implement-rollback

[CBR-150] Implement rollback

Author: edsko

wallet-new/cardano-sl-wallet-new.cabal

@@ -422,6 +422,7 @@ test-suite wallet-unit-tests
                       Wallet.Inductive.Generator
                       Wallet.Inductive.Interpreter
                       Wallet.Inductive.Invariants
+                      Wallet.Inductive.History
                       Wallet.Inductive.Validation
                       Wallet.Prefiltered
                       Wallet.Rollback.Basic

wallet-new/src/Cardano/Wallet/Kernel.hs

@@ -9,15 +9,19 @@ module Cardano.Wallet.Kernel (
     PassiveWallet -- opaque
   , DB -- opaque
   , WalletId
-  , applyBlock
-  , applyBlocks
   , bracketPassiveWallet
   , init
   , walletLogMessage
   , walletPassive
-    -- * The only effectful getter you will ever need
+    -- ** Respond to block chain events
+  , applyBlock
+  , applyBlocks
+  , switchToFork
+    -- *** Testing
+  , observableRollbackUseInTestsOnly
+    -- ** The only effectful getter you will ever need
   , getWalletSnapshot
-    -- * Pure getters acting on a DB snapshot
+    -- ** Pure getters acting on a DB snapshot
   , module Getters
     -- * Active wallet
   , ActiveWallet -- opaque
@@ -49,7 +53,8 @@ import           Cardano.Wallet.Kernel.Types (WalletId (..))
 
 import           Cardano.Wallet.Kernel.DB.AcidState (ApplyBlock (..),
                      CancelPending (..), DB, NewPending (..), NewPendingError,
-                     Snapshot (..), defDB)
+                     ObservableRollbackUseInTestsOnly (..), Snapshot (..),
+                     SwitchToFork (..), defDB)
 import           Cardano.Wallet.Kernel.DB.HdWallet
 import           Cardano.Wallet.Kernel.DB.InDb
 import           Cardano.Wallet.Kernel.DB.Resolved (ResolvedBlock)
@@ -140,7 +145,7 @@ applyBlock pw@PassiveWallet{..} b
     = do
         blocksByAccount <- prefilterBlock' pw b
         -- apply block to all Accounts in all Wallets
-        void $ update' _wallets $ ApplyBlock blocksByAccount
+        update' _wallets $ ApplyBlock blocksByAccount
 
 -- | Apply multiple blocks, one at a time, to all wallets in the PassiveWallet
 --
@@ -150,6 +155,25 @@ applyBlocks :: PassiveWallet
             -> IO ()
 applyBlocks = mapM_ . applyBlock
 
+-- | Switch to a new fork
+--
+-- NOTE: The Ouroboros protocol says that this is only valid if the number of
+-- resolved blocks exceeds the length of blocks to roll back.
+switchToFork :: PassiveWallet
+             -> Int             -- ^ Number of blocks to roll back
+             -> [ResolvedBlock] -- ^ Blocks in the new fork
+             -> IO ()
+switchToFork pw@PassiveWallet{..} n bs = do
+    blockssByAccount <- mapM (prefilterBlock' pw) bs
+    update' _wallets $ SwitchToFork n blockssByAccount
+
+-- | Observable rollback
+--
+-- Only used for tests. See 'switchToFork'.
+observableRollbackUseInTestsOnly :: PassiveWallet -> IO ()
+observableRollbackUseInTestsOnly PassiveWallet{..} =
+    update' _wallets $ ObservableRollbackUseInTestsOnly
+
 {-------------------------------------------------------------------------------
   Active wallet
 -------------------------------------------------------------------------------}

wallet-new/src/Cardano/Wallet/Kernel/DB/AcidState.hs

@@ -26,8 +26,10 @@ module Cardano.Wallet.Kernel.DB.AcidState (
     -- *** DELETE
   , DeleteHdRoot(..)
   , DeleteHdAccount(..)
-    -- * errors
+    -- * Errors
   , NewPendingError
+    -- * Testing
+  , ObservableRollbackUseInTestsOnly(..)
   ) where
 
 import           Universum
@@ -38,6 +40,7 @@ import           Control.Monad.Except (MonadError, catchError)
 import           Test.QuickCheck (Arbitrary (..), oneof)
 
 import           Data.Acid (Query, Update, makeAcidic)
+import qualified Data.Map.Merge.Strict as Map.Merge
 import qualified Data.Map.Strict as Map
 import           Data.SafeCopy (base, deriveSafeCopy)
 import           Formatting (bprint, build, (%))
@@ -47,8 +50,9 @@ import           Pos.Core.Chrono (OldestFirst (..))
 import qualified Pos.Core.Txp as Txp
 import           Pos.Txp (Utxo)
 
+import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet
 import           Cardano.Wallet.Kernel.PrefilterTx (AddrWithId,
-                     PrefilteredBlock (..))
+                     PrefilteredBlock (..), emptyPrefilteredBlock)
 
 import           Cardano.Wallet.Kernel.DB.HdWallet
 import qualified Cardano.Wallet.Kernel.DB.HdWallet.Create as HD
@@ -160,21 +164,26 @@ cancelPending cancelled = void . runUpdate' . zoom dbHdWallets $
 -- * For every address encountered in the block outputs, create an HdAddress if it
 -- does not already exist.
 applyBlock :: Map HdAccountId PrefilteredBlock -> Update DB ()
-applyBlock blocksByAccount = runUpdateNoErrors $ zoom dbHdWallets $
+applyBlock blocksByAccount = runUpdateNoErrors $ zoom dbHdWallets $ do
+    blocksByAccount' <- fillInEmptyBlock blocksByAccount
     createPrefiltered
         initUtxoAndAddrs
         (\prefBlock -> zoom hdAccountCheckpoints $
                            modify $ Spec.applyBlock prefBlock)
-        blocksByAccount
+        blocksByAccount'
   where
-    -- NOTE: When we create the new wallet, we look at the genesis UTxO and create
-    -- an initial balance for all accounts that we recognize as ours. This means that
-    -- when we later discover a new account that is also ours, it cannot appear
-    -- in the genesis UTxO, because if it did, we would already have seen it
-    -- (the genesis UTxO is static, after all). Hence we use empty initial utxo
-    -- for accounts discovered during applyBlock.
-    -- The Addrs need to be created during account initialisation and so we pass them here.
-    initUtxoAndAddrs :: PrefilteredBlock -> (Utxo,[AddrWithId])
+    -- Initial UTxO and addresses for a new account
+    --
+    -- NOTE: When we initialize the kernel, we look at the genesis UTxO and create
+    -- an initial balance for all accounts that we recognize as ours. This means
+    -- that when we later discover a new account that is also ours, it cannot appear
+    -- in the genesis UTxO, because if it did, we would already have seen it (the
+    -- genesis UTxO is static, after all). Hence we use empty initial utxo for
+    -- accounts discovered during 'applyBlock' (and 'switchToFork')
+    --
+    -- The Addrs need to be created during account initialisation and so we pass
+    -- them here.
+    initUtxoAndAddrs :: PrefilteredBlock -> (Utxo, [AddrWithId])
     initUtxoAndAddrs pb = (Map.empty, pfbAddrs pb)
 
 -- | Switch to a fork
@@ -184,11 +193,40 @@ applyBlock blocksByAccount = runUpdateNoErrors $ zoom dbHdWallets $
 -- TODO: We use a plain list here rather than 'OldestFirst' since the latter
 -- does not have a 'SafeCopy' instance.
 switchToFork :: Int
-             -> [PrefilteredBlock]
+             -> [Map HdAccountId PrefilteredBlock]
              -> Update DB ()
-switchToFork n blocks = runUpdateNoErrors $
+switchToFork n blocks = runUpdateNoErrors $ zoom dbHdWallets $ do
+    blocks' <- mapM fillInEmptyBlock blocks
+    createPrefiltered
+        initUtxoAndAddrs
+        (\prefBlocks -> zoom hdAccountCheckpoints $
+                            modify $ Spec.switchToFork n (OldestFirst prefBlocks))
+        (distribute blocks')
+  where
+    -- 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
+    --
+    -- NOTE: We have to be careful to /first/ use 'fillInEmptyBlock' to 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.
+    distribute :: [Map HdAccountId PrefilteredBlock]
+               -> Map HdAccountId [PrefilteredBlock]
+    distribute = Map.unionsWith (++) . map (Map.map (:[]))
+
+    -- See comments in 'applyBlock'
+    initUtxoAndAddrs :: [PrefilteredBlock] -> (Utxo, [AddrWithId])
+    initUtxoAndAddrs pbs = (Map.empty, concatMap pfbAddrs pbs)
+
+-- | Observable rollback, used for tests only
+--
+-- See 'switchToFork' for use in real code.
+observableRollbackUseInTestsOnly :: Update DB ()
+observableRollbackUseInTestsOnly = runUpdateNoErrors $
     zoomAll (dbHdWallets . hdWalletsAccounts) $
-        hdAccountCheckpoints %~ Spec.switchToFork n (OldestFirst blocks)
+      hdAccountCheckpoints %~ Spec.observableRollbackUseInTestsOnly
+
+
 
 {-------------------------------------------------------------------------------
   Wallet creation
@@ -215,8 +253,37 @@ createHdWallet newRoot utxoByAccount = runUpdate' . zoom dbHdWallets $ do
   Internal auxiliary: apply a function to a prefiltered block/utxo
 -------------------------------------------------------------------------------}
 
+-- | Given a map from account IDs, add default values for all accounts in
+-- the wallet that aren't given a value in the map
+fillInDefaults :: forall p e.
+                  (HdAccount -> p)   -- ^ Default value
+               -> Map HdAccountId p  -- ^ Map with values per account
+               -> Update' HdWallets e (Map HdAccountId p)
+fillInDefaults def accs =
+    aux . IxSet.toMap <$> use hdWalletsAccounts
+  where
+    aux :: Map HdAccountId HdAccount -> Map HdAccountId p
+    aux = Map.Merge.merge newAccount needsDefault valueForExistingAcc accs
+
+    newAccount :: Map.Merge.SimpleWhenMissing HdAccountId p p
+    newAccount = Map.Merge.mapMaybeMissing $ \_accId p -> Just p
+
+    needsDefault :: Map.Merge.SimpleWhenMissing HdAccountId HdAccount p
+    needsDefault = Map.Merge.mapMaybeMissing $ \_accId acc -> Just (def acc)
+
+    valueForExistingAcc :: Map.Merge.SimpleWhenMatched HdAccountId p HdAccount p
+    valueForExistingAcc = Map.Merge.zipWithMatched $ \_accId p _acc -> p
+
+-- | Specialization of 'fillInDefaults' for prefiltered blocks
+fillInEmptyBlock :: Map HdAccountId PrefilteredBlock
+                 -> Update' HdWallets e (Map HdAccountId PrefilteredBlock)
+fillInEmptyBlock = fillInDefaults (const emptyPrefilteredBlock)
+
 -- | For each of the specified accounts, create them if they do not exist,
 -- and apply the specified function.
+--
+-- NOTE: Any accounts that aren't in the map are simply skilled. See
+-- 'fillInDefaults'.
 createPrefiltered :: forall p e.
                      (p -> (Utxo,[AddrWithId]))
                       -- ^ Initial UTxO (when we are creating the account),
@@ -257,7 +324,6 @@ createPrefiltered initUtxoAndAddrs applyP accs = do
             firstCheckpoint utxo' = Checkpoint {
                   _checkpointUtxo        = InDb utxo'
                 , _checkpointUtxoBalance = InDb $ Spec.balance utxo'
-                , _checkpointExpected    = InDb Map.empty
                 , _checkpointPending     = Pending . InDb $ Map.empty
                 -- Since this is the first checkpoint before we have applied
                 -- any blocks, the block metadata is empty
@@ -329,4 +395,6 @@ makeAcidic ''DB [
     , 'updateHdAccountName
     , 'deleteHdRoot
     , 'deleteHdAccount
+      -- Testing
+    , 'observableRollbackUseInTestsOnly
     ]

wallet-new/src/Cardano/Wallet/Kernel/DB/BlockMeta.hs

@@ -16,6 +16,9 @@ import           Control.Lens.TH (makeLenses)
 import qualified Data.Map.Strict as Map
 import           Data.SafeCopy (SafeCopy (..), base, contain, deriveSafeCopy,
                      safeGet, safePut)
+import           Formatting (bprint, build, (%))
+import qualified Formatting.Buildable
+import           Serokell.Util (mapJson)
 
 import qualified Pos.Core as Core
 import qualified Pos.Core.Txp as Txp
@@ -81,3 +84,27 @@ instance Monoid BlockMeta where
           _blockMetaAddressMeta = InDb Map.empty
       }
   mappend = (<>)
+
+{-------------------------------------------------------------------------------
+  Pretty-printing
+-------------------------------------------------------------------------------}
+
+instance Buildable AddressMeta where
+    build AddressMeta{..} = bprint
+        ( "AddressMeta"
+        % "{ isUsed:   " % build
+        % ", isChange: " % build
+        % "}"
+        )
+        _addressMetaIsUsed
+        _addressMetaIsChange
+
+instance Buildable BlockMeta where
+    build BlockMeta{..} = bprint
+        ( "BlockMeta"
+        % "{ slotId:      " % mapJson
+        % ", addressMeta: " % mapJson
+        % "}"
+        )
+        (_fromDb _blockMetaSlotId)
+        (_fromDb _blockMetaAddressMeta)

wallet-new/src/Cardano/Wallet/Kernel/DB/Spec.hs

@@ -14,14 +14,12 @@ module Cardano.Wallet.Kernel.DB.Spec (
   , pendingTransactions
   , checkpointUtxo
   , checkpointUtxoBalance
-  , checkpointExpected
   , checkpointPending
   , checkpointBlockMeta
     -- ** Lenses into the current checkpoint
   , currentCheckpoint
   , currentUtxo
   , currentUtxoBalance
-  , currentExpected
   , currentPending
   , currentPendingTxs
   , currentBlockMeta
@@ -33,9 +31,9 @@ import           Control.Lens (to)
 import           Control.Lens.TH (makeLenses)
 import qualified Data.Map.Strict as M
 import           Data.SafeCopy (base, deriveSafeCopy)
-import           Formatting (bprint, (%))
-import           Formatting.Buildable (build)
-import           Serokell.Util.Text (listJsonIndent)
+import           Formatting (bprint, build, (%))
+import qualified Formatting.Buildable
+import           Serokell.Util.Text (listJsonIndent, mapJson)
 
 import qualified Pos.Core as Core
 import qualified Pos.Core.Txp as Txp
@@ -80,11 +78,23 @@ removePending ids (Pending (InDb old)) = Pending (InDb $ old `withoutKeys` ids)
 
 -- | Per-wallet state
 --
--- This is the same across all wallet types.
+-- NOTE: At the moment this does not included the expected UTxO. The expected
+-- UTxO is used for two things:
+--
+-- * Block resolution (translating tx inputs to their corresponding outputs, so
+--   that we know the corresponding addresses, needed for prefilering)
+-- * Minimum balance computation
+--
+-- Fortunately however we can rely on a full node as backing, so we don't need
+-- to use the expected UTxO for block resolution (this is explained in the
+-- formal spec in section "Prefiltering -- Consequences", under "possible
+-- alternatives"), and minimum balance computation is a new feature that we
+-- haven't implemented yet.
+--
+-- NOTE: This is the same across all wallet types.
 data Checkpoint = Checkpoint {
       _checkpointUtxo        :: InDb Core.Utxo
     , _checkpointUtxoBalance :: InDb Core.Coin
-    , _checkpointExpected    :: InDb Core.Utxo
     , _checkpointPending     :: Pending
     , _checkpointBlockMeta   :: BlockMeta
     }
@@ -107,14 +117,12 @@ currentCheckpoint = neHead
 
 currentUtxo        :: Lens' Checkpoints Core.Utxo
 currentUtxoBalance :: Lens' Checkpoints Core.Coin
-currentExpected    :: Lens' Checkpoints Core.Utxo
 currentBlockMeta   :: Lens' Checkpoints BlockMeta
 currentPending     :: Lens' Checkpoints Pending
 currentPendingTxs  :: Lens' Checkpoints PendingTxs
 
 currentUtxo        = currentCheckpoint . checkpointUtxo        . fromDb
 currentUtxoBalance = currentCheckpoint . checkpointUtxoBalance . fromDb
-currentExpected    = currentCheckpoint . checkpointExpected    . fromDb
 currentBlockMeta   = currentCheckpoint . checkpointBlockMeta
 currentPending     = currentCheckpoint . checkpointPending
 currentPendingTxs  = currentPending . pendingTransactions . fromDb
@@ -134,3 +142,17 @@ instance Buildable Pending where
     build (Pending p) =
       let elems = p ^. fromDb . to M.toList
       in bprint ("Pending " % listJsonIndent 4) (map fst elems)
+
+instance Buildable Checkpoint where
+    build Checkpoint{..} = bprint
+        ( "Checkpoint"
+        % "{ utxo:        " % mapJson
+        % ", utxoBalance: " % build
+        % ", pending:     " % build
+        % ", blockMeta:   " % build
+        % "}"
+        )
+      (_fromDb _checkpointUtxo)
+      (_fromDb _checkpointUtxoBalance)
+      _checkpointPending
+      _checkpointBlockMeta