Merge branch 'feature/dae111-txhistory-cache' into cardano-sl-0.2

Author: flyingleafe

src/Pos/Wallet/WalletMode.hs

@@ -9,6 +9,7 @@
 module Pos.Wallet.WalletMode
        ( MonadBalances (..)
        , MonadTxHistory (..)
+       , TxHistoryAnswer (..)
        , MonadBlockchainInfo (..)
        , MonadUpdates (..)
        , TxMode
@@ -48,7 +49,7 @@ import           Pos.Txp.Class               (getMemPool, getUtxoView)
 import qualified Pos.Txp.Holder              as Modern
 import           Pos.Txp.Logic               (processTx)
 import           Pos.Txp.Types               (UtxoView (..), localTxs)
-import           Pos.Types                   (Address, BlockHeader, ChainDifficulty, Coin,
+import           Pos.Types                   (Address, BlockHeader, ChainDifficulty, Coin, HeaderHash,
                                               TxAux, TxId, Utxo, difficultyL,
                                               evalUtxoStateT, flattenEpochOrSlot,
                                               flattenSlotId, prevBlockL, runUtxoStateT,
@@ -64,7 +65,7 @@ import           Pos.Wallet.Context          (ContextHolder, WithWalletContext)
 import           Pos.Wallet.KeyStorage       (KeyStorage, MonadKeys)
 import           Pos.Wallet.State            (WalletDB)
 import qualified Pos.Wallet.State            as WS
-import           Pos.Wallet.Tx.Pure          (TxHistoryEntry, deriveAddrHistory,
+import           Pos.Wallet.Tx.Pure          (TxHistoryEntry, deriveAddrHistory, thDifficulty,
                                               deriveAddrHistoryPartial, getRelatedTxs)
 import           Pos.Wallet.Web.State        (WalletWebDB (..))
 
@@ -109,13 +110,23 @@ instance (MonadDB ssc m, MonadMask m) => MonadBalances (Modern.TxpLDHolder ssc m
 
 --deriving instance MonadBalances m => MonadBalances (Modern.TxpLDHolder m)
 
+data TxHistoryAnswer = TxHistoryAnswer
+    { taLastCachedHash :: HeaderHash
+    , taCachedNum      :: Int
+    , taCachedUtxo     :: Utxo
+    , taHistory        :: [TxHistoryEntry]
+    } deriving (Show)
+
 -- | A class which have methods to get transaction history
 class Monad m => MonadTxHistory m where
-    getTxHistory :: Address -> m [TxHistoryEntry]
+    getTxHistory
+        :: Address -> Maybe (HeaderHash, Utxo) -> m TxHistoryAnswer
     saveTx :: (TxId, TxAux) -> m ()
 
-    default getTxHistory :: (MonadTrans t, MonadTxHistory m', t m' ~ m) => Address -> m [TxHistoryEntry]
-    getTxHistory = lift . getTxHistory
+    default getTxHistory
+        :: (MonadTrans t, MonadTxHistory m', t m' ~ m)
+        => Address -> Maybe (HeaderHash, Utxo) -> m TxHistoryAnswer
+    getTxHistory addr = lift . getTxHistory addr
 
     default saveTx :: (MonadTrans t, MonadTxHistory m', t m' ~ m) => (TxId, TxAux) -> m ()
     saveTx = lift . saveTx
@@ -138,20 +149,22 @@ deriving instance MonadTxHistory m => MonadTxHistory (WalletWebDB m)
 
 -- | Get tx history for Address
 instance MonadIO m => MonadTxHistory (WalletDB m) where
-    getTxHistory addr = do
+    getTxHistory addr _ = do
         chain <- WS.getBestChain
         utxo <- WS.getOldestUtxo
-        fmap (fst . fromMaybe (panic "deriveAddrHistory: Nothing")) $
+        res <- fmap (fst . fromMaybe (panic "deriveAddrHistory: Nothing")) $
             runMaybeT $ flip runUtxoStateT utxo $
             deriveAddrHistory addr chain
+        pure undefined
     saveTx _ = pure ()
 
-instance (SscHelpersClass ssc, MonadDB ssc m, MonadThrow m, WithLogger m)
+instance (SscHelpersClass ssc, MonadDB ssc m, MonadThrow m, WithLogger m, PC.WithNodeContext ssc m)
          => MonadTxHistory (Modern.TxpLDHolder ssc m) where
-    getTxHistory addr = do
-        bot <- GS.getBot
+    getTxHistory addr mInit = do
         tip <- GS.getTip
-        genUtxo <- GS.getFilteredGenUtxo addr
+
+        let getGenUtxo = filterUtxoByAddr addr . PC.ncGenesisUtxo <$> PC.getNodeContext
+        (bot, genUtxo) <- maybe ((,) <$> GS.getBot <*> getGenUtxo) pure mInit
 
         -- Getting list of all hashes in main blockchain (excluding bottom block - it's genesis anyway)
         hashList <- flip unfoldrM tip $ \h ->
@@ -163,6 +176,10 @@ instance (SscHelpersClass ssc, MonadDB ssc m, MonadThrow m, WithLogger m)
                 let prev = header ^. prevBlockL
                 return $ Just (h, prev)
 
+        -- Determine last block which txs should be cached
+        let cachedHashes = drop blkSecurityParam hashList
+            nonCachedHashes = take blkSecurityParam hashList
+
         let blockFetcher h txs = do
                 blk <- lift . lift $ DB.getBlock h >>=
                        maybeThrow (DBMalformed "A block mysteriously disappeared!")
@@ -173,9 +190,18 @@ instance (SscHelpersClass ssc, MonadDB ssc m, MonadThrow m, WithLogger m)
                 txs <- getRelatedTxs addr $ map mp ltxs
                 return $ txs ++ blkTxs
 
-        result <- runMaybeT $
-            evalUtxoStateT (foldrM blockFetcher [] hashList >>= localFetcher) genUtxo
-        maybe (panic "deriveAddrHistory: Nothing") return result
+        mres <- runMaybeT $ do
+            (cachedTxs, cachedUtxo) <- runUtxoStateT
+                (foldrM blockFetcher [] cachedHashes) genUtxo
+    
+            result <- evalUtxoStateT
+                (foldrM blockFetcher cachedTxs nonCachedHashes >>= localFetcher)
+                cachedUtxo
+
+            let lastCachedHash = maybe bot identity $ head cachedHashes
+            return $ TxHistoryAnswer lastCachedHash (length cachedTxs) cachedUtxo result
+
+        maybe (panic "deriveAddrHistory: Nothing") pure mres
 
     saveTx txw = () <$ processTx txw
 

src/Pos/Wallet/Web/Server/Methods.hs

@@ -49,9 +49,9 @@ import           Pos.Wallet.KeyStorage         (KeyError (..), MonadKeys (..),
                                                 addSecretKey)
 import           Pos.Wallet.Tx                 (sendTxOuts, submitTx)
 import           Pos.Wallet.Tx.Pure            (TxHistoryEntry (..))
-import           Pos.Wallet.WalletMode         (WalletMode, applyLastUpdate,
-                                                blockchainSlotDuration, connectedPeers,
-                                                getBalance, getTxHistory,
+import           Pos.Wallet.WalletMode         (TxHistoryAnswer (..), WalletMode,
+                                                applyLastUpdate, blockchainSlotDuration,
+                                                connectedPeers, getBalance, getTxHistory,
                                                 localChainDifficulty,
                                                 networkChainDifficulty, waitForUpdate)
 import           Pos.Wallet.Web.Api            (WalletApi, walletApi)
@@ -71,11 +71,13 @@ import           Pos.Wallet.Web.Server.Sockets (MonadWalletWebSockets (..),
                                                 notify, runWalletWS, upgradeApplicationWS)
 import           Pos.Wallet.Web.State          (MonadWalletWebDB (..), WalletWebDB,
                                                 addOnlyNewTxMeta, addUpdate, closeState,
-                                                createWallet, getNextUpdate, getProfile,
-                                                getTxMeta, getWalletMeta, getWalletState,
-                                                openState, removeNextUpdate, removeWallet,
+                                                createWallet, getHistoryCache,
+                                                getNextUpdate, getProfile, getTxMeta,
+                                                getWalletMeta, getWalletState, openState,
+                                                removeNextUpdate, removeWallet,
                                                 runWalletWebDB, setProfile, setWalletMeta,
-                                                setWalletTransactionMeta)
+                                                setWalletTransactionMeta,
+                                                updateHistoryCache)
 import           Pos.Web.Server                (serveImpl)
 
 ----------------------------------------------------------------------------
@@ -294,7 +296,7 @@ decodeCAddressOrFail = either wrongAddress pure . cAddressToAddress
 getWallets :: WalletWebMode ssc m => m [CWallet]
 getWallets = join $ mapM getWallet <$> myCAddresses
 
-send :: WalletWebMode ssc m =>  SendActions m -> CAddress -> CAddress -> Coin -> m CTx
+send :: WalletWebMode ssc m => SendActions m -> CAddress -> CAddress -> Coin -> m CTx
 send sendActions srcCAddr dstCAddr c =
     sendExtended sendActions srcCAddr dstCAddr c ADA mempty mempty
 
@@ -320,11 +322,23 @@ sendExtended sendActions srcCAddr dstCAddr c curr title desc = do
 
 getHistory :: WalletWebMode ssc m => CAddress -> Word -> Word -> m ([CTx], Word)
 getHistory cAddr skip limit = do
-    history <- getTxHistory =<< decodeCAddressOrFail cAddr
-    cHistory <- mapM (addHistoryTx cAddr ADA mempty mempty) history
-    pure (paginate cHistory, fromIntegral $ length cHistory)
+    (minit, cachedTxs) <- transCache <$> getHistoryCache cAddr
+
+    TxHistoryAnswer {..} <- flip getTxHistory minit
+        =<< decodeCAddressOrFail cAddr
+    cHistory <- mapM (addHistoryTx cAddr ADA mempty mempty) taHistory
+
+    -- Add allowed portion of result to cache
+    let fullHistory = cHistory <> cachedTxs
+        lenHistory = length cHistory
+        cached = drop (lenHistory - taCachedNum) cHistory
+    updateHistoryCache cAddr taLastCachedHash taCachedUtxo cached
+
+    pure (paginate fullHistory, fromIntegral $ length fullHistory)
   where
     paginate = take (fromIntegral limit) . drop (fromIntegral skip)
+    transCache Nothing                = (Nothing, [])
+    transCache (Just (hh, utxo, txs)) = (Just (hh, utxo), txs)
 
 -- FIXME: is Word enough for length here?
 searchHistory :: WalletWebMode ssc m => CAddress -> Text -> Word -> Word -> m ([CTx], Word)

src/Pos/Wallet/Web/State/Acidic.hs

@@ -18,6 +18,7 @@ module Pos.Wallet.Web.State.Acidic
        , GetTxMeta (..)
        , GetUpdates (..)
        , GetNextUpdate (..)
+       , GetHistoryCache (..)
        , CreateWallet (..)
        , SetProfile (..)
        , SetWalletMeta (..)
@@ -28,6 +29,7 @@ module Pos.Wallet.Web.State.Acidic
        , RemoveWallet (..)
        , AddUpdate (..)
        , RemoveNextUpdate (..)
+       , UpdateHistoryCache (..)
        ) where
 
 import           Universum
@@ -74,6 +76,7 @@ makeAcidic ''WalletStorage
     , 'WS.getTxMeta
     , 'WS.getUpdates
     , 'WS.getNextUpdate
+    , 'WS.getHistoryCache
     , 'WS.createWallet
     , 'WS.setProfile
     , 'WS.setWalletMeta
@@ -84,4 +87,5 @@ makeAcidic ''WalletStorage
     , 'WS.removeWallet
     , 'WS.addUpdate
     , 'WS.removeNextUpdate
+    , 'WS.updateHistoryCache
     ]

src/Pos/Wallet/Web/State/State.hs

@@ -17,6 +17,7 @@ module Pos.Wallet.Web.State.State
        , getWalletHistory
        , getUpdates
        , getNextUpdate
+       , getHistoryCache
 
        -- * Setters
        , createWallet
@@ -28,6 +29,7 @@ module Pos.Wallet.Web.State.State
        , removeWallet
        , addUpdate
        , removeNextUpdate
+       , updateHistoryCache
        ) where
 
 import           Data.Acid                    (EventResult, EventState, QueryEvent,
@@ -36,8 +38,9 @@ import           Mockable                     (MonadMockable)
 import           Universum
 
 import           Pos.Slotting                 (NtpSlotting)
-import           Pos.Wallet.Web.ClientTypes   (CAddress, CProfile, CTxId, CTxMeta,
-                                               CUpdateInfo, CWalletMeta)
+import           Pos.Types                    (HeaderHash, Utxo)
+import           Pos.Wallet.Web.ClientTypes   (CAddress, CHash, CProfile, CTx, CTxId,
+                                               CTxMeta, CUpdateInfo, CWalletMeta)
 import           Pos.Wallet.Web.State.Acidic  (WalletState, closeState, openMemState,
                                                openState)
 import           Pos.Wallet.Web.State.Acidic  as A
@@ -91,6 +94,9 @@ getUpdates = queryDisk A.GetUpdates
 getNextUpdate :: WebWalletModeDB m => m (Maybe CUpdateInfo)
 getNextUpdate = queryDisk A.GetNextUpdate
 
+getHistoryCache :: WebWalletModeDB m => CAddress -> m (Maybe (HeaderHash, Utxo, [CTx]))
+getHistoryCache = queryDisk . A.GetHistoryCache
+
 createWallet :: WebWalletModeDB m => CAddress -> CWalletMeta -> m ()
 createWallet addr = updateDisk . A.CreateWallet addr
 
@@ -117,3 +123,6 @@ addUpdate = updateDisk . A.AddUpdate
 
 removeNextUpdate :: WebWalletModeDB m => m ()
 removeNextUpdate = updateDisk A.RemoveNextUpdate
+
+updateHistoryCache :: WebWalletModeDB m => CAddress -> HeaderHash -> Utxo -> [CTx] -> m ()
+updateHistoryCache cAddr h utxo = updateDisk . A.UpdateHistoryCache cAddr h utxo

src/Pos/Wallet/Web/State/Storage.hs

@@ -14,6 +14,7 @@ module Pos.Wallet.Web.State.Storage
        , getTxMeta
        , getUpdates
        , getNextUpdate
+       , getHistoryCache
        , createWallet
        , setWalletMeta
        , setWalletHistory
@@ -23,14 +24,16 @@ module Pos.Wallet.Web.State.Storage
        , removeWallet
        , addUpdate
        , removeNextUpdate
+       , updateHistoryCache
        ) where
 
 import           Control.Lens               (at, ix, makeClassy, (%=), (.=), _Just, _head)
 import           Data.Default               (Default, def)
 import           Data.SafeCopy              (base, deriveSafeCopySimple)
-import           Pos.Wallet.Web.ClientTypes (CAddress, CCurrency, CHash, CProfile, CTxId,
-                                             CTxMeta, CUpdateInfo, CWalletMeta,
-                                             CWalletType)
+import           Pos.Types                  (HeaderHash, Utxo)
+import           Pos.Wallet.Web.ClientTypes (CAddress, CCurrency, CHash, CProfile, CTType,
+                                             CTx, CTxId, CTxMeta, CUpdateInfo,
+                                             CWalletMeta, CWalletType)
 import           Universum
 
 type TransactionHistory = HashMap CTxId CTxMeta
@@ -40,6 +43,7 @@ data WalletStorage = WalletStorage
       _wsWalletMetas  :: !(HashMap CAddress (CWalletMeta, TransactionHistory))
     , _wsProfile      :: !(Maybe CProfile)
     , _wsReadyUpdates :: [CUpdateInfo]
+    , _wsHistoryCache :: !(HashMap CAddress (HeaderHash, Utxo, [CTx]))
     }
 
 makeClassy ''WalletStorage
@@ -51,6 +55,7 @@ instance Default WalletStorage where
           _wsWalletMetas = mempty
         , _wsProfile = mzero
         , _wsReadyUpdates = mempty
+        , _wsHistoryCache = mempty
         }
 
 type Query a = forall m. (MonadReader WalletStorage m) => m a
@@ -80,6 +85,9 @@ getUpdates = view wsReadyUpdates
 getNextUpdate :: Query (Maybe CUpdateInfo)
 getNextUpdate = preview (wsReadyUpdates . _head)
 
+getHistoryCache :: CAddress -> Query (Maybe (HeaderHash, Utxo, [CTx]))
+getHistoryCache cAddr = view $ wsHistoryCache . at cAddr
+
 createWallet :: CAddress -> CWalletMeta -> Update ()
 createWallet cAddr wMeta = wsWalletMetas . at cAddr .= Just (wMeta, mempty)
 
@@ -107,9 +115,12 @@ addUpdate :: CUpdateInfo -> Update ()
 addUpdate ui = wsReadyUpdates %= (++ [ui])
 
 removeNextUpdate :: Update ()
-removeNextUpdate = wsReadyUpdates %= \case
-    [] -> []
-    (_:as) -> as
+removeNextUpdate = wsReadyUpdates %= drop 1
+
+updateHistoryCache :: CAddress -> HeaderHash -> Utxo -> [CTx] -> Update ()
+updateHistoryCache cAddr cHash utxo cTxs = do
+    oldTxs <- use $ wsHistoryCache . at cAddr . _Just . _3
+    wsHistoryCache . at cAddr .= Just (cHash, utxo, cTxs <> oldTxs)
 
 deriveSafeCopySimple 0 'base ''CProfile
 deriveSafeCopySimple 0 'base ''CHash
@@ -118,6 +129,8 @@ deriveSafeCopySimple 0 'base ''CCurrency
 deriveSafeCopySimple 0 'base ''CWalletType
 deriveSafeCopySimple 0 'base ''CWalletMeta
 deriveSafeCopySimple 0 'base ''CTxId
+deriveSafeCopySimple 0 'base ''CTType
+deriveSafeCopySimple 0 'base ''CTx
 deriveSafeCopySimple 0 'base ''CTxMeta
 deriveSafeCopySimple 0 'base ''CUpdateInfo
 deriveSafeCopySimple 0 'base ''WalletStorage

util-scripts/build.sh

@@ -47,7 +47,7 @@ do
 done
 
 # TODO: how can --ghc-options be moved into commonargs?
-commonargs='--test --no-haddock-deps --bench --jobs=4'
+commonargs='--no-haddock-deps --bench --jobs=4'
 norun='--no-run-tests --no-run-benchmarks'
 webwallet='--flag cardano-sl:with-web --flag cardano-sl:with-wallet'