Merge pull request #150 from input-output-hk/KtorZ/90/manipulate-tx-h…

…istory-independently

Store TxHistory outside of the wallet state

src/Cardano/Wallet.hs

@@ -14,7 +14,20 @@
 -- intermediary between the three.
 
 
-module Cardano.Wallet where
+module Cardano.Wallet
+    (
+    -- * Types
+      WalletLayer (..)
+    , NewWallet(..)
+    , ReadWalletError(..)
+    , CreateWalletError(..)
+
+    -- * Construction
+    , mkWalletLayer
+
+    -- * Helpers
+    , unsafeRunExceptT
+    ) where
 
 import Prelude
 
@@ -37,17 +50,24 @@ import Cardano.Wallet.Primitive.Types
     ( Block (..), WalletId (..), WalletMetadata (..), WalletName (..) )
 import Control.Exception
     ( Exception )
+import Control.Monad
+    ( (>=>) )
+import Control.Monad.Fail
+    ( MonadFail )
 import Control.Monad.IO.Class
     ( liftIO )
 import Control.Monad.Trans.Except
-    ( ExceptT, throwE )
+    ( ExceptT, runExceptT, throwE )
 import Data.List
     ( foldl' )
 import GHC.Generics
     ( Generic )
 
 
--- | Types
+{-------------------------------------------------------------------------------
+                                 Types
+-------------------------------------------------------------------------------}
+
 data WalletLayer s = WalletLayer
     { createWallet
         :: NewWallet
@@ -83,6 +103,9 @@ newtype CreateWalletError
     = ErrCreateWalletIdAlreadyExists WalletId
     deriving (Eq, Show)
 
+{-------------------------------------------------------------------------------
+                                 Construction
+-------------------------------------------------------------------------------}
 
 -- | Create a new instance of the wallet layer.
 mkWalletLayer
@@ -123,10 +146,27 @@ mkWalletLayer db network = WalletLayer
   where
     applyBlocks :: WalletId -> [Block] -> IO ()
     applyBlocks wid blocks = do
-        cp' <- readCheckpoint db (PrimaryKey wid) >>= \case
+        (txs, cp') <- readCheckpoint db (PrimaryKey wid) >>= \case
             Nothing ->
                 fail $ "couldn't find worker wallet: " <> show wid
             Just cp -> do
                 let nonEmpty = not . null . transactions
-                return $ foldl' (flip applyBlock) cp (filter nonEmpty blocks)
+                let applyOne (txs, cp') b = (txs <> txs', cp'') where
+                        (txs', cp'') = applyBlock b cp'
+                return $ foldl' applyOne (mempty, cp) (filter nonEmpty blocks)
         putCheckpoint db (PrimaryKey wid) cp'
+        unsafeRunExceptT $ putTxHistory db (PrimaryKey wid) txs -- Safe after ^
+
+{-------------------------------------------------------------------------------
+                                 Helpers
+-------------------------------------------------------------------------------}
+
+-- | Run an ExcepT and throws the error if any. This makes sense only if called
+-- after checking for an invariant or, after ensuring that preconditions for
+-- meeting the underlying error have been discarded.
+unsafeRunExceptT :: (MonadFail m, Show e) => ExceptT e m a -> m a
+unsafeRunExceptT = runExceptT >=> \case
+    Left e ->
+        fail $ "unexpected error: " <> show e
+    Right a ->
+        return a

src/Cardano/Wallet/DB.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DataKinds #-}
+
 -- |
 -- Copyright: © 2018-2019 IOHK
 -- License: MIT
@@ -8,35 +10,66 @@
 module Cardano.Wallet.DB
     ( DBLayer(..)
     , PrimaryKey(..)
+    , ErrPutTxHistory(..)
     ) where
 
 import Prelude
 
 import Cardano.Wallet.Primitive.Model
     ( Wallet )
 import Cardano.Wallet.Primitive.Types
-    ( WalletId )
+    ( Hash, Tx, TxMeta, WalletId )
+import Control.Monad.Trans.Except
+    ( ExceptT )
+import Data.Map.Strict
+    ( Map )
 
 
 -- | A Database interface for storing various things in a DB. In practice,
 -- we'll need some extra contraints on the wallet state that allows us to
 -- serialize and unserialize it (e.g. @forall s. (Serialize s) => ...@)
 data DBLayer m s = DBLayer
-    -- Wallet checkpoints, checkpoints are handled as a bounded FIFO, where we
-    -- eventually store @k@ values (e.g. k=2160) at the same time.
     { putCheckpoint
         :: PrimaryKey WalletId
         -> Wallet s
         -> m ()
+        -- ^ Replace the current checkpoint for a given wallet. We do not handle
+        -- rollbacks yet, and therefore only stores the latest available
+        -- checkpoint.
 
     , readCheckpoint
         :: PrimaryKey WalletId
         -> m (Maybe (Wallet s))
+        -- ^ Fetch the most recent checkpoint of a given wallet. Return 'Nothing'
+        -- if there's no such wallet.
 
     , readWallets
         :: m [PrimaryKey WalletId]
+        -- ^ Get the list of all known wallets in the DB, possibly empty.
+
+    , putTxHistory
+        :: PrimaryKey WalletId
+        -> Map (Hash "Tx") (Tx, TxMeta)
+        -> ExceptT ErrPutTxHistory m ()
+        -- ^ Augments the transaction history for a known wallet.
+        --
+        -- If an entry for a particular transaction already exists it is not
+        -- altered nor merged (just ignored).
+        --
+        -- If the wallet doesn't exist, this operation returns an error.
+
+    , readTxHistory
+        :: PrimaryKey WalletId
+        -> m (Map (Hash "Tx") (Tx, TxMeta))
+        -- ^ Fetch the current transaction history of a known wallet. Returns an
+        -- empty map if the wallet isn't found.
     }
 
+-- | Error while trying to insert transaction history in the DB.
+newtype ErrPutTxHistory
+    = ErrNoSuchWallet WalletId
+    deriving (Show, Eq)
+
 -- | A primary key which can take many forms depending on the value. This may
 -- become a type family as we move forward, but for now, it illustrate that
 -- some queries are ran against some sort of store;

src/Cardano/Wallet/DB/MVar.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 
 -- |
@@ -15,25 +17,52 @@ module Cardano.Wallet.DB.MVar
 import Prelude
 
 import Cardano.Wallet.DB
-    ( DBLayer (..) )
+    ( DBLayer (..), ErrPutTxHistory (..), PrimaryKey (..) )
+import Cardano.Wallet.Primitive.Model
+    ( Wallet )
+import Cardano.Wallet.Primitive.Types
+    ( Hash, Tx, TxMeta, WalletId )
 import Control.Concurrent.MVar
-    ( modifyMVar_, newMVar, readMVar )
+    ( modifyMVar, modifyMVar_, newMVar, readMVar )
 import Control.DeepSeq
     ( deepseq )
+import Control.Monad.Trans.Except
+    ( ExceptT (..) )
+import Data.Map.Strict
+    ( Map )
 
 import qualified Data.Map.Strict as Map
 
-
 -- | Instantiate a new in-memory "database" layer that simply stores data in
 -- a local MVar. Data vanishes if the software is shut down.
 newDBLayer :: forall s. IO (DBLayer IO s)
 newDBLayer = do
-    wallets <- newMVar mempty
+    db <- newMVar (mempty
+        :: Map (PrimaryKey WalletId) (Wallet s, Map (Hash "Tx") (Tx, TxMeta)))
     return $ DBLayer
         { putCheckpoint = \key cp ->
-            cp `deepseq` (modifyMVar_ wallets (return . Map.insert key cp))
+            let
+                alter = \case
+                    Nothing -> Just (cp, mempty)
+                    Just (_, history) -> Just (cp, history)
+            in
+                cp `deepseq` modifyMVar_ db (return . (Map.alter alter key))
+
         , readCheckpoint = \key ->
-            Map.lookup key <$> readMVar wallets
+            fmap fst . Map.lookup key <$> readMVar db
+
         , readWallets =
-            Map.keys <$> readMVar wallets
+            Map.keys <$> readMVar db
+
+        , putTxHistory = \key@(PrimaryKey wid) txs' -> ExceptT $ do
+            let alter = \case
+                    Nothing -> Left (ErrNoSuchWallet wid)
+                    Just (cp, txs) -> Right (Just (cp, txs <> txs'))
+            let handle m = \case
+                    Left err -> return (m, Left err)
+                    Right m' -> return (m', Right ())
+            txs' `deepseq` modifyMVar db (\m -> handle m $ Map.alterF alter key m)
+
+        , readTxHistory = \key ->
+            maybe mempty snd . Map.lookup key <$> readMVar db
         }

src/Cardano/Wallet/Primitive/Model.hs

@@ -52,6 +52,7 @@ import Cardano.Wallet.Primitive.Types
     ( Block (..)
     , Direction (..)
     , Dom (..)
+    , Hash (..)
     , IsOurs (..)
     , SlotId (..)
     , Tx (..)
@@ -77,6 +78,8 @@ import Data.Generics.Internal.VL.Lens
     ( (^.) )
 import Data.Generics.Labels
     ()
+import Data.Map.Strict
+    ( Map )
 import Data.Maybe
     ( catMaybes )
 import Data.Quantity
@@ -89,6 +92,9 @@ import Numeric.Natural
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
+{-------------------------------------------------------------------------------
+                                     Type
+-------------------------------------------------------------------------------}
 
 -- | An opaque wallet type, see @initWallet@ and @applyBlock@ to construct and
 -- update wallets.
@@ -103,7 +109,7 @@ data Wallet s where
     Wallet :: (IsOurs s, NFData s, Show s)
         => UTxO -- Unspent tx outputs belonging to this wallet
         -> Set Tx -- Pending transactions
-        -> Set (Tx, TxMeta) -- Transaction history
+        -> Set (Hash "Tx") -- Transaction history
         -> SlotId -- Latest applied block (current tip)
         -> s -- Address discovery state
         -> Wallet s
@@ -118,27 +124,44 @@ instance NFData (Wallet s) where
         deepseq (rnf sl) $
         deepseq (rnf s) ()
 
+{-------------------------------------------------------------------------------
+                          Construction & Modification
+-------------------------------------------------------------------------------}
+
 -- | Create an empty wallet from an initial state
 initWallet
     :: (IsOurs s, NFData s, Show s)
     => s
     -> Wallet s
 initWallet = Wallet mempty mempty mempty (SlotId 0 0)
 
--- | Apply Block is the only way to make the wallet evolve.
+-- | Apply Block is the only way to make the wallet evolve. It returns a new
+-- updated wallet state, as well as the set of all our transaction discovered
+-- while applying the block.
 applyBlock
     :: Block
     -> Wallet s
-    -> Wallet s
-applyBlock !b (Wallet !utxo !pending !txs _ s) =
+    -> (Map (Hash "Tx") (Tx, TxMeta), Wallet s)
+applyBlock !b (Wallet !utxo !pending !history _ s) =
     let
-        -- Prefilter Block
-        ((txs', utxo'), s') = prefilterBlock b utxo s
+        -- Prefilter Block / Update UTxO
+        ((txs, utxo'), s') = prefilterBlock b utxo s
         -- Update Pending
-        newIns = txIns (Set.map fst txs')
+        newIns = txIns (Set.map fst txs)
         pending' = pending `pendingExcluding` newIns
+        -- Update Tx history
+        txs' = Map.fromList $ Set.toList $ Set.map
+            (\(tx, meta) -> (txId tx, (tx, meta)))
+            txs
+        history' = history <> Map.keysSet txs'
     in
-        Wallet utxo' pending' (txs <> txs') (b ^. #header . #slotId) s'
+        ( txs'
+        , Wallet utxo' pending' history' (b ^. #header . #slotId) s'
+        )
+
+{-------------------------------------------------------------------------------
+                                   Accessors
+-------------------------------------------------------------------------------}
 
 -- | Get the wallet current tip
 currentTip :: Wallet s -> SlotId
@@ -149,8 +172,8 @@ getState :: Wallet s -> s
 getState (Wallet _ _ _ _ s) = s
 
 -- | Get the transaction metadata for transactions associated with the wallet.
-getTxHistory :: Wallet s -> Set (Tx, TxMeta)
-getTxHistory (Wallet _ _ txs _ _) = txs
+getTxHistory :: Wallet s -> Set (Hash "Tx")
+getTxHistory (Wallet _ _ history _ _) = history
 
 -- | Available balance = 'balance' . 'availableUTxO'
 availableBalance :: Wallet s -> Natural
@@ -162,12 +185,12 @@ totalBalance :: Wallet s -> Natural
 totalBalance =
     balance . totalUTxO
 
--- | Available UTxO = UTxO that aren't part of pending txs
+-- | Available UTxO = @pending ⋪ utxo@
 availableUTxO :: Wallet s -> UTxO
 availableUTxO (Wallet utxo pending _ _ _) =
     utxo `excluding` txIns pending
 
--- | Total UTxO = 'availableUTxO' <> "pending UTxO"
+-- | Total UTxO = 'availableUTxO' @<>@ 'changeUTxO'
 totalUTxO :: Wallet s -> UTxO
 totalUTxO wallet@(Wallet _ pending _ _ s) =
     availableUTxO wallet <> changeUTxO pending s
@@ -256,9 +279,10 @@ changeUTxO pending = evalState $ do
     let ins = txIns pending
     return $ fold ourUtxo `restrictedBy` ins
 
--- | 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.
+-- | Construct our _next_ UTxO (possible empty) from a transaction by selecting
+-- outputs that are ours. It is important for the transaction outputs to be
+-- ordered correctly, since they become available inputs for the subsequent
+-- blocks.
 utxoOurs :: IsOurs s => Tx -> s -> (UTxO, s)
 utxoOurs tx = runState $ toUtxo <$> forM (zip [0..] (outputs tx)) filterOut
   where

test/integration/Cardano/WalletSpec.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -12,7 +11,7 @@ import Prelude
 import Cardano.Launcher
     ( Command (..), StdStream (..), launch )
 import Cardano.Wallet
-    ( NewWallet (..), WalletLayer (..), mkWalletLayer )
+    ( NewWallet (..), WalletLayer (..), mkWalletLayer, unsafeRunExceptT )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( Passphrase (..) )
 import Cardano.Wallet.Primitive.Mnemonic
@@ -25,12 +24,6 @@ import Control.Concurrent
     ( threadDelay )
 import Control.Concurrent.Async
     ( async, cancel )
-import Control.Monad
-    ( (>=>) )
-import Control.Monad.Fail
-    ( MonadFail )
-import Control.Monad.Trans.Except
-    ( ExceptT, runExceptT )
 import Test.Hspec
     ( Spec, after, before, it, shouldSatisfy )
 
@@ -73,10 +66,3 @@ spec = do
         (handle,) <$> (mkWalletLayer
             <$> MVar.newDBLayer
             <*> HttpBridge.newNetworkLayer "testnet" port)
-
-unsafeRunExceptT :: (MonadFail m, Show e) => ExceptT e m a -> m a
-unsafeRunExceptT = runExceptT >=> \case
-    Left e ->
-        fail $ "unable to perform expect IO action: " <> show e
-    Right a ->
-        return a