diff --git a/lib/network-layer/cardano-wallet-network-layer.cabal b/lib/network-layer/cardano-wallet-network-layer.cabal index de2dafb2ca0..d3d98a0cbd3 100644 --- a/lib/network-layer/cardano-wallet-network-layer.cabal +++ b/lib/network-layer/cardano-wallet-network-layer.cabal @@ -112,6 +112,7 @@ test-suite unit , bytestring , cardano-wallet-network-layer , cardano-wallet-primitive + , cardano-wallet-read , contra-tracer , io-classes , text diff --git a/lib/network-layer/src/Cardano/Wallet/Network/Light.hs b/lib/network-layer/src/Cardano/Wallet/Network/Light.hs index 8b2d6e85f3d..b28fd5cf070 100644 --- a/lib/network-layer/src/Cardano/Wallet/Network/Light.hs +++ b/lib/network-layer/src/Cardano/Wallet/Network/Light.hs @@ -31,9 +31,7 @@ import Cardano.Wallet.Network ) import Cardano.Wallet.Primitive.Types.Block ( BlockHeader (..) - , ChainPoint (..) - , chainPointFromBlockHeader - , compareSlot + , chainPointFromBlockHeader' ) import Cardano.Wallet.Primitive.Types.BlockSummary ( BlockSummary (..) @@ -69,6 +67,7 @@ import GHC.Generics ( Generic ) +import qualified Cardano.Wallet.Read as Read import qualified Data.Text as T {------------------------------------------------------------------------------- @@ -86,10 +85,10 @@ data LightSyncSource m block addr txs = LightSyncSource -- ^ Get the 'BlockHeader' at a given block height. , getNextBlockHeader :: BlockHeader -> m (Consensual (Maybe BlockHeader)) -- ^ Get the next block header. - , getBlockHeaderAt :: ChainPoint -> m (Consensual BlockHeader) + , getBlockHeaderAt :: Read.ChainPoint -> m (Consensual BlockHeader) -- ^ Get the full 'BlockHeader' belonging to a given 'ChainPoint'. -- Return 'Nothing' if the point is not consensus anymore. - , getNextBlocks :: ChainPoint -> m (Consensual [block]) + , getNextBlocks :: Read.ChainPoint -> m (Consensual [block]) -- ^ Get several blocks immediately following the given 'Chainpoint'. , getAddressTxs :: BlockHeader -> BlockHeader -> addr -> m txs -- ^ Transactions for a given address and point range. @@ -113,23 +112,35 @@ type LightBlocks m block addr txs = Either (NonEmpty block) (BlockSummary m addr txs) -- | Retrieve the 'ChainPoint' with the highest 'Slot'. -latest :: [ChainPoint] -> ChainPoint -latest [] = ChainPointAtGenesis +latest :: [Read.ChainPoint] -> Read.ChainPoint +latest [] = Read.GenesisPoint latest xs = maximumBy compareSlot xs -- | Retrieve the 'ChainPoint' with the second-highest 'Slot'. -secondLatest :: [ChainPoint] -> ChainPoint -secondLatest [] = ChainPointAtGenesis -secondLatest [_] = ChainPointAtGenesis +secondLatest :: [Read.ChainPoint] -> Read.ChainPoint +secondLatest [] = Read.GenesisPoint +secondLatest [_] = Read.GenesisPoint secondLatest xs = head . tail $ sortBy (flip compareSlot) xs +-- | Compare the slot numbers of two 'Read.ChainPoint's, +-- but where the 'Read.GenesisPoint' comes before all other slot numbers. +compareSlot :: Read.ChainPoint -> Read.ChainPoint -> Ordering +compareSlot pt1 pt2 = compare (toOrdered pt1) (toOrdered pt2) + where + toOrdered :: Read.ChainPoint -> Integer + toOrdered Read.GenesisPoint = -1 + toOrdered (Read.BlockPoint (Read.SlotNo nat) _) = toInteger nat + -- | Drive a 'ChainFollower' using a 'LightSyncSource'. -- Never returns. lightSync :: MonadDelay m => Tracer m LightLayerLog -> LightSyncSource m block addr txs - -> ChainFollower m ChainPoint BlockHeader (LightBlocks m block addr txs) + -> ChainFollower m + Read.ChainPoint + BlockHeader + (LightBlocks m block addr txs) -> m Void lightSync tr light follower = readChainPoints follower >>= syncFrom . latest where @@ -147,10 +158,10 @@ lightSync tr light follower = readChainPoints follower >>= syncFrom . latest traceWith tr $ MsgLightRollForward chainPoint old new tip rollForward follower (Right $ mkBlockSummary light old new) tip traceWith tr $ MsgLightRolledForward new - pure $ chainPointFromBlockHeader new + pure $ chainPointFromBlockHeader' new WaitForANewTip tip -> do threadDelay 2 -- seconds - $> chainPointFromBlockHeader tip + $> chainPointFromBlockHeader' tip data NextPointMove block = RollForward @@ -191,7 +202,7 @@ consensually k ca = proceedToNextPoint :: Monad m => LightSyncSource m block addr txs - -> ChainPoint + -> Read.ChainPoint -> m (NextPointMove block) proceedToNextPoint LightSyncSource{..} chainPoint = getBlockHeaderAt chainPoint >>= consensually \currentBlock -> @@ -236,10 +247,10 @@ mkBlockSummary light old new = BlockSummary -------------------------------------------------------------------------------} data LightLayerLog = MsgLightRollForward - ChainPoint BlockHeader BlockHeader BlockHeader + Read.ChainPoint BlockHeader BlockHeader BlockHeader | MsgLightRolledForward BlockHeader | MsgLightRollBackward - ChainPoint ChainPoint + Read.ChainPoint Read.ChainPoint deriving (Show, Eq, Generic) instance ToText LightLayerLog where @@ -247,7 +258,7 @@ instance ToText LightLayerLog where MsgLightRollForward cp_ from_ to_ tip -> T.unwords [ "LightLayer started rolling forward:" - , "chain_point: ", pretty cp_ + , "chain_point: ", Read.prettyChainPoint cp_ , "from: ", pretty from_ , "to: ", pretty to_ , "tip: ", pretty tip @@ -260,8 +271,8 @@ instance ToText LightLayerLog where MsgLightRollBackward from_ to_ -> T.unwords [ "LightLayer roll backward:" - , "from: ", pretty from_ - , "to: ", pretty to_ + , "from: ", Read.prettyChainPoint from_ + , "to: ", Read.prettyChainPoint to_ ] instance HasPrivacyAnnotation LightLayerLog diff --git a/lib/network-layer/test/Cardano/Wallet/Network/LightSpec.hs b/lib/network-layer/test/Cardano/Wallet/Network/LightSpec.hs index 853da6d51d8..90da1957c6d 100644 --- a/lib/network-layer/test/Cardano/Wallet/Network/LightSpec.hs +++ b/lib/network-layer/test/Cardano/Wallet/Network/LightSpec.hs @@ -24,8 +24,7 @@ import Cardano.Wallet.Network.Light ) import Cardano.Wallet.Primitive.Types.Block ( BlockHeader (..) - , ChainPoint (..) - , chainPointFromBlockHeader + , chainPointFromBlockHeader' , isGenesisBlockHeader ) import Cardano.Wallet.Primitive.Types.BlockSummary @@ -33,6 +32,7 @@ import Cardano.Wallet.Primitive.Types.BlockSummary ) import Cardano.Wallet.Primitive.Types.Hash ( Hash (..) + , mockHash ) import Control.Monad ( ap @@ -89,7 +89,8 @@ import Test.QuickCheck ) import qualified Cardano.Wallet.Primitive.Types.Checkpoints.Policy as CP -import qualified Data.ByteString.Char8 as B8 +import qualified Cardano.Wallet.Read as Read +import qualified Cardano.Wallet.Read.Hash as Hash import qualified Data.List as L import qualified Data.List.NonEmpty as NE import qualified Data.Text as T @@ -145,7 +146,7 @@ mkLightSyncSourceMock = LightSyncSource , getAddressTxs = \_ _ _ -> pure () } where - toPoint = chainPointFromBlockHeader + toPoint = chainPointFromBlockHeader' toHeight = fromIntegral . fromEnum . blockHeight data ChainHistory = ChainHistory !MockChain ![(DeltaChain, MockChain)] @@ -198,12 +199,12 @@ genesisBlock :: Block genesisBlock = BlockHeader { slotNo = 0 , blockHeight = Quantity 0 - , headerHash = mockHash 0 + , headerHash = mockHashInt 0 , parentHeaderHash = Nothing } -mockHash :: Int -> Hash "BlockHeader" -mockHash = Hash . B8.pack . show +mockHashInt :: Int -> Hash "BlockHeader" +mockHashInt = mockHash mockStabilityWindow :: Int mockStabilityWindow = 5 @@ -308,7 +309,7 @@ evalMockMonad action0 (ChainHistory chain0 deltas0) s0 -- | Run a 'ChainFollower' based on the full synchronization. fullSync - :: ChainFollower (MockMonad s) ChainPoint BlockHeader + :: ChainFollower (MockMonad s) Read.ChainPoint BlockHeader (LightBlocks (MockMonad s) Block addr txs) -> MockMonad s Void fullSync follower = forever $ do @@ -317,7 +318,7 @@ fullSync follower = forever $ do Idle -> wait Forward bs tip -> rollForward follower (Left bs) tip Backward target -> void $ - rollBackward follower $ chainPointFromBlockHeader target + rollBackward follower $ chainPointFromBlockHeader' target {------------------------------------------------------------------------------- Implementation of a ChainFollower @@ -334,14 +335,14 @@ latest = NE.head -- | Make a 'ChainFollower' for 'FollowerState'. mkFollower :: (forall a. State FollowerState a -> m a) - -> ChainFollower m ChainPoint BlockHeader + -> ChainFollower m Read.ChainPoint BlockHeader (LightBlocks m Block addr txs) mkFollower lift = ChainFollower { checkpointPolicy = \epochStability -> CP.atTip <> CP.atGenesis <> CP.trailingArithmetic 2 (min 1 $ epochStability `div` 3) , readChainPoints = - lift $ map chainPointFromBlockHeader . NE.toList <$> get + lift $ map chainPointFromBlockHeader' . NE.toList <$> get , rollForward = \blocks _tip -> lift $ modify $ \s -> case blocks of Left bs -> @@ -354,11 +355,13 @@ mkFollower lift = ChainFollower else error "lightSync: BlockSummary out of order" , rollBackward = \target -> lift $ do modify $ NE.fromList . NE.dropWhile (`after` target) - chainPointFromBlockHeader . NE.head <$> get + chainPointFromBlockHeader' . NE.head <$> get } where - bh `after` ChainPointAtGenesis = not (isGenesisBlockHeader bh) - bh `after` (ChainPoint slot _) = slotNo bh > slot + bh `after` Read.GenesisPoint = + not (isGenesisBlockHeader bh) + bh `after` (Read.BlockPoint (Read.SlotNo slot) _) = + slotNo bh > fromIntegral slot isParentOf :: BlockHeader -> BlockHeader -> Bool isParentOf parent = (== Just (headerHash parent)) . parentHeaderHash @@ -366,10 +369,10 @@ mkFollower lift = ChainFollower showBlockChain :: NonEmpty BlockHeader -> String showBlockChain = unwords . L.intersperse "->" . fmap showBlockHeader . NE.toList -showChainPoint :: ChainPoint -> String +showChainPoint :: Read.ChainPoint -> String showChainPoint = \case - ChainPointAtGenesis -> "G" - ChainPoint _ h -> show $ getHash h + Read.GenesisPoint -> "Genesis" + Read.BlockPoint _ h -> Hash.hashToStringAsHex h showBlockHeader :: BlockHeader -> String showBlockHeader = unHash . headerHash