diff --git a/lib/benchmarks/exe/api-bench.hs b/lib/benchmarks/exe/api-bench.hs index a1d27206d1a..0c50a1b4962 100644 --- a/lib/benchmarks/exe/api-bench.hs +++ b/lib/benchmarks/exe/api-bench.hs @@ -144,9 +144,6 @@ import Data.Aeson , genericToJSON , (.=) ) -import Data.Maybe - ( fromJust - ) import Data.Quantity ( Quantity (..) ) @@ -183,10 +180,8 @@ import qualified Cardano.Wallet.DB.Layer as DB import qualified Cardano.Wallet.DB.Layer as Sqlite import qualified Cardano.Wallet.Primitive.Types.UTxOStatistics as UTxOStatistics import qualified Cardano.Wallet.Read as Read -import qualified Cardano.Wallet.Read.Hash as Hash import qualified Cardano.Wallet.Transaction as Tx import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Char8 as B8 import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Internal.Cardano.Write.Tx as Write @@ -554,7 +549,7 @@ mockNetworkLayer = dummyNetworkLayer } mockHash :: Read.RawHeaderHash -mockHash = fromJust $ Hash.hashFromBytes (B8.replicate 32 'a') +mockHash = Read.mockRawHeaderHash 0 mockTimeInterpreter :: TimeInterpreter IO mockTimeInterpreter = dummyTimeInterpreter diff --git a/lib/network-layer/src/Cardano/Wallet/Network.hs b/lib/network-layer/src/Cardano/Wallet/Network.hs index 6b1202fdabf..9a0d9534454 100644 --- a/lib/network-layer/src/Cardano/Wallet/Network.hs +++ b/lib/network-layer/src/Cardano/Wallet/Network.hs @@ -145,7 +145,7 @@ data NetworkLayer m block = NetworkLayer -- ^ Get the last known slotting parameters. In principle, these can -- only change once per era. , watchNodeTip - :: (BlockHeader -> m ()) + :: (Read.ChainTip -> m ()) -> m () -- ^ Register a callback for when the node tip changes. -- This function should never finish, unless the callback throws an diff --git a/lib/network-layer/src/Cardano/Wallet/Network/Implementation.hs b/lib/network-layer/src/Cardano/Wallet/Network/Implementation.hs index 3569f91c598..5eef8182112 100644 --- a/lib/network-layer/src/Cardano/Wallet/Network/Implementation.hs +++ b/lib/network-layer/src/Cardano/Wallet/Network/Implementation.hs @@ -99,7 +99,6 @@ import Cardano.Wallet.Primitive.Ledger.Read.Block.Header ) import Cardano.Wallet.Primitive.Ledger.Shelley ( fromPoint - , fromTip , fromTip' , nodeToClientVersions , toCardanoEra @@ -385,6 +384,7 @@ import qualified Cardano.Wallet.Primitive.SyncProgress as SP import qualified Cardano.Wallet.Primitive.Types.Coin as W import qualified Cardano.Wallet.Primitive.Types.RewardAccount as W import qualified Cardano.Wallet.Primitive.Types.Tx as W +import qualified Cardano.Wallet.Read as Read import qualified Codec.CBOR.Term as CBOR import qualified Data.Map as Map import qualified Data.Set as Set @@ -654,10 +654,11 @@ withNodeNetworkLayerBase return res Nothing -> pure $ StakePoolsSummary 0 mempty mempty - _watchNodeTip readTip cb = do + _watchNodeTip readTip callback = do observeForever readTip $ \tip -> do - let header = fromTip getGenesisBlockHash tip - bracketTracer (contramap (MsgWatcherUpdate header) tr) $ cb header + let tip' = fromOuroborosTip tip + bracketTracer (contramap (MsgWatcherUpdate tip') tr) + $ callback tip' -- TODO(#2042): Make wallets call manually, with matching stopObserving. _getCachedRewardAccountBalance rewardsObserver k = do @@ -1356,7 +1357,7 @@ data Log where -> Log -- ^ Number of pools in stake distribution, and rewards map, -- respectively. - MsgWatcherUpdate :: BlockHeader -> BracketLog -> Log + MsgWatcherUpdate :: Read.ChainTip -> BracketLog -> Log MsgInterpreter :: CardanoInterpreter StandardCrypto -> Log -- TODO: Combine ^^ and vv MsgInterpreterLog :: TimeInterpreterLog -> Log @@ -1428,7 +1429,7 @@ instance ToText Log where ] MsgWatcherUpdate tip b -> "Update watcher with tip: " - <> pretty tip + <> Read.prettyChainTip tip <> ". Callback " <> toText b <> "." diff --git a/lib/read/lib/Cardano/Wallet/Read/Block.hs b/lib/read/lib/Cardano/Wallet/Read/Block.hs index d3eeec431d9..b51692c3d50 100644 --- a/lib/read/lib/Cardano/Wallet/Read/Block.hs +++ b/lib/read/lib/Cardano/Wallet/Read/Block.hs @@ -33,6 +33,7 @@ import Cardano.Wallet.Read.Block.HeaderHash , getEraHeaderHash , getEraPrevHeaderHash , getRawHeaderHash + , mockRawHeaderHash ) import Cardano.Wallet.Read.Block.SlotNo ( SlotNo (..) diff --git a/lib/read/lib/Cardano/Wallet/Read/Block/HeaderHash.hs b/lib/read/lib/Cardano/Wallet/Read/Block/HeaderHash.hs index 463726fb641..831fb871846 100644 --- a/lib/read/lib/Cardano/Wallet/Read/Block/HeaderHash.hs +++ b/lib/read/lib/Cardano/Wallet/Read/Block/HeaderHash.hs @@ -16,6 +16,9 @@ module Cardano.Wallet.Read.Block.HeaderHash , PrevHeaderHash (..) , PrevHeaderHashT , getEraPrevHeaderHash + + -- * Testing utilities + , mockRawHeaderHash ) where @@ -81,6 +84,8 @@ import Ouroboros.Consensus.Shelley.Protocol.TPraos import qualified Cardano.Crypto.Hashing as Byron import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Shelley.API as Shelley +import qualified Cardano.Wallet.Read.Hash as Hash +import qualified Data.ByteString.Char8 as B8 import qualified Ouroboros.Consensus.Shelley.Ledger.Block as O import qualified Ouroboros.Consensus.Shelley.Protocol.Abstract as Shelley import qualified Ouroboros.Network.Block as O @@ -131,6 +136,11 @@ data BHeader -- | Raw hash digest for a block header. type RawHeaderHash = Hash Blake2b_256 BHeader +-- | Construct a 'RawHeaderHash' that is good enough for testing. +mockRawHeaderHash :: Integer -> RawHeaderHash +mockRawHeaderHash n = + Hash.hashWith (\_ -> B8.pack $ show n) (error "undefined :: BHeader") + {-# INLINABLE getRawHeaderHash #-} getRawHeaderHash :: forall era. IsEra era => HeaderHash era -> RawHeaderHash getRawHeaderHash = case theEra @era of diff --git a/lib/unit/test/unit/Cardano/Wallet/Api/ServerSpec.hs b/lib/unit/test/unit/Cardano/Wallet/Api/ServerSpec.hs index 87b83dee002..b07c5479a7a 100644 --- a/lib/unit/test/unit/Cardano/Wallet/Api/ServerSpec.hs +++ b/lib/unit/test/unit/Cardano/Wallet/Api/ServerSpec.hs @@ -74,8 +74,7 @@ import Data.Either ( isLeft ) import Data.Maybe - ( fromJust - , isJust + ( isJust , isNothing ) import Data.SOP.Counting @@ -143,7 +142,6 @@ import UnliftIO.Concurrent import qualified Cardano.Wallet.Primitive.SyncProgress as S import qualified Cardano.Wallet.Read as Read -import qualified Cardano.Wallet.Read.Hash as Hash import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as BL import qualified Ouroboros.Consensus.HardFork.History.EraParams as HF @@ -278,7 +276,7 @@ networkInfoSpec = describe "getNetworkInformation" $ do } where mockHash :: Read.RawHeaderHash - mockHash = fromJust $ Hash.hashFromBytes $ B8.replicate 32 'a' + mockHash = Read.mockRawHeaderHash 0 forkInterpreter startTime = let diff --git a/lib/unit/test/unit/Cardano/WalletSpec.hs b/lib/unit/test/unit/Cardano/WalletSpec.hs index 160b0eb17b6..aefc5f90709 100644 --- a/lib/unit/test/unit/Cardano/WalletSpec.hs +++ b/lib/unit/test/unit/Cardano/WalletSpec.hs @@ -125,7 +125,6 @@ import Cardano.Wallet.Primitive.Passphrase.Current ) import Cardano.Wallet.Primitive.Types ( ActiveSlotCoefficient (..) - , BlockHeader (BlockHeader) , NetworkParameters (..) , SlotNo (..) , SlottingParameters (..) @@ -1002,13 +1001,20 @@ prop_localTxSubmission tc = monadicIO $ do , watchNodeTip = mockNodeTip (numSlots tc) 0 } - mockNodeTip end sl cb - | sl < end = do - let h = Hash "" - void $ cb $ BlockHeader (SlotNo sl) (Quantity (fromIntegral sl)) h (Just h) - mockNodeTip end (sl + 1) cb + mockNodeTip end slot callback + | slot < end = do + let tip = Read.BlockTip + { slotNo = Read.SlotNo $ fromIntegral slot + , headerHash = mockHash + , blockNo = Read.BlockNo $ fromIntegral slot + } + void $ callback tip + mockNodeTip end (slot + 1) callback | otherwise = pure () + mockHash :: Read.RawHeaderHash + mockHash = Read.mockRawHeaderHash 0 + stash :: MVar [a] -> a -> TxRetryTestM () stash var x = modifyMVar_ var (\xs -> pure (x:xs)) diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 84bc7db3081..5b97eae3ea2 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -1651,8 +1651,8 @@ manageRewardBalance -> DBLayer IO (SeqState n ShelleyKey) -> IO () manageRewardBalance tr' netLayer db = do - watchNodeTip netLayer $ \bh -> do - traceWith tr $ MsgRewardBalanceQuery bh + watchNodeTip netLayer $ \nodeTip -> do + traceWith tr $ MsgRewardBalanceQuery nodeTip query <- do (acct, _, _) <- readRewardAccount db liftIO $ getCachedRewardAccountBalance netLayer acct @@ -1695,8 +1695,8 @@ manageSharedRewardBalance -> DBLayer IO (SharedState n SharedKey) -> IO () manageSharedRewardBalance tr' netLayer db = do - watchNodeTip netLayer $ \bh -> do - traceWith tr $ MsgRewardBalanceQuery bh + watchNodeTip netLayer $ \nodeTip -> do + traceWith tr $ MsgRewardBalanceQuery nodeTip query <- runExceptT $ do (acct, _, _) <- lift $ readRewardAccount @(SharedState n SharedKey) db @@ -2804,10 +2804,13 @@ runLocalTxSubmissionPool -> WalletLayer m s -> m () runLocalTxSubmissionPool cfg ctx = db & \DBLayer{..} -> do - submitPending <- rateLimited $ \bh -> bracketTracer trBracket $ do + submitPending <- rateLimited $ \nodeTip -> bracketTracer trBracket $ do sp <- currentSlottingParameters nw pending <- readLocalTxSubmissionPending ctx - let sl = bh ^. #slotNo + let sl = case nodeTip of + Read.GenesisTip -> SlotNo 0 + Read.BlockTip{slotNo} -> + SlotNo $ fromIntegral $ Read.unSlotNo slotNo pendingOldStyle = pending >>= mkLocalTxSubmission -- Re-submit transactions due, ignore errors forM_ (filter (isScheduled sp sl) pendingOldStyle) $ \st -> do @@ -3856,7 +3859,7 @@ data WalletFollowLog data WalletLog = MsgMigrationUTxOBefore UTxOStatistics | MsgMigrationUTxOAfter UTxOStatistics - | MsgRewardBalanceQuery BlockHeader + | MsgRewardBalanceQuery Read.ChainTip | MsgRewardBalanceResult (Either ErrFetchRewards Coin) | MsgRewardBalanceExited | MsgTxSubmit TxSubmitLog @@ -3906,8 +3909,9 @@ instance ToText WalletLog where "About to migrate the following distribution: \n" <> pretty summary MsgMigrationUTxOAfter summary -> "Expected distribution after complete migration: \n" <> pretty summary - MsgRewardBalanceQuery bh -> - "Updating the reward balance for block " <> pretty bh + MsgRewardBalanceQuery nodeTip -> + "Updating the reward balance for block " + <> Read.prettyChainTip nodeTip MsgRewardBalanceResult (Right amt) -> "The reward balance is " <> pretty amt MsgRewardBalanceResult (Left err) ->