Change lightSync to use Read.ChainPoint

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

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,18 +247,18 @@ 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
     toText = \case
         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

lib/network-layer/test/Cardano/Wallet/Network/LightSpec.hs

@@ -24,15 +24,15 @@ import Cardano.Wallet.Network.Light
     )
 import Cardano.Wallet.Primitive.Types.Block
     ( BlockHeader (..)
-    , ChainPoint (..)
-    , chainPointFromBlockHeader
+    , chainPointFromBlockHeader'
     , isGenesisBlockHeader
     )
 import Cardano.Wallet.Primitive.Types.BlockSummary
     ( 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,22 +355,24 @@ 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
 
 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