[CBR-150] Implement rollback

Also wrote a hand-written test to test specifically for dependent pending
transactions, because the generator doesn't always hit that case (and fixed the
bug that Ryan intentionally left in because he rightly wanted a test first that
exposes it first).

Also fixed a bug in the test infrastructure: the interpreter requires state
that depends on the blockchain (hash of the previous block, the stake
distrubtion, etc). It is therefore important that we correctly track this state
and rollback the interpreter state when there is a rollback in the blockchain.

Added shrinking to test comparing the kernel to the pure model.

Author: edsko

core/src/Pos/Core/Common/Coin.hs

@@ -153,4 +153,3 @@ unsafeIntegerToCoin n = leftToPanic "unsafeIntegerToCoin: " (integerToCoin n)
 
 -- Place this here to avoid TH staging issues.
 deriveSafeCopySimple 0 'base ''Coin
-

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

@@ -11,18 +11,22 @@ module Cardano.Wallet.Kernel (
     PassiveWallet -- opaque
   , DB -- opaque
   , WalletId
-  , applyBlock
-  , applyBlocks
   , bracketPassiveWallet
   , createWalletHdRnd
   , init
   , walletLogMessage
   , walletPassive
   , walletKeystore
   , wallets
-    -- * 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
@@ -53,7 +57,9 @@ import           Cardano.Wallet.Kernel.Types (WalletId (..))
 
 import           Cardano.Wallet.Kernel.DB.AcidState (ApplyBlock (..),
                      CancelPending (..), CreateHdWallet (..), DB,
-                     NewPending (..), NewPendingError, Snapshot (..), defDB)
+                     NewPending (..), NewPendingError,
+                     ObservableRollbackUseInTestsOnly (..), Snapshot (..),
+                     SwitchToFork (..), defDB)
 import           Cardano.Wallet.Kernel.DB.HdWallet
 import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD
 import qualified Cardano.Wallet.Kernel.DB.HdWallet.Create as HD
@@ -211,7 +217,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
 --
@@ -221,6 +227,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
@@ -36,15 +38,17 @@ import           Control.Lens.TH (makeLenses)
 import           Control.Monad.Except (MonadError, catchError)
 
 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 qualified Pos.Core as Core
 import           Pos.Core.Chrono (OldestFirst (..))
 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
@@ -145,21 +149,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
@@ -169,11 +178,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
@@ -200,8 +238,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),
@@ -242,7 +309,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
@@ -314,4 +380,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
 
@@ -80,3 +83,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.Txp as Core
@@ -79,11 +77,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
     }
@@ -106,14 +116,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
@@ -133,3 +141,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