-
Notifications
You must be signed in to change notification settings - Fork 217
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
3175: Light NetworkLayer: lightSync r=HeinrichApfelmus a=HeinrichApfelmus ### Issue number ADP-1422, ADP-1427 ### Overview [Light-mode][] (Epic ADP-1422) aims to make synchronisation to the blockchain faster by trusting an off-chain source of aggregated blockchain data. [light-mode]: https://input-output-hk.github.io/cardano-wallet/design/specs/light-mode In this pull request, we implement `lightSync`, the "crown jewel" 👑 of light-mode: * `lightSync` drives a `ChainFollower` with `LightBlocks` by polling an external blockchain data source (represented by `LightSyncSource`) as opposed to being pushed by a cardano-node. * `prop_followLightSync` tests this rigorously by simulating a randomly evolving blockchain with rollbacks. ### Details * `lightSync` is implemented and tested, but propagating it to `NetworkLayer` is left for a future pull request. * `secondsPerSlot` is currently hard-coded to 2 seconds; also left for the future when the shape of `LightLayer` becomes more clear. ### Comments * I have opted to *not* use [quickcheck-state-machine][qsm], as I felt that the trouble of setting up the `Reference` type machinery did not seem worth the benefit. * However, I have kept the principle of first generating a history (`genChainHistory`) and then driving a (monadic) state machine with it (`evalMockMonad`) — it was just easier to do it "by hand". * That said, *labelling* histories to check that interesting histories have been generated would be a good idea — but I'm sufficiently confident in the present implementation that I would like to postpone this for a future time, also because I envision some synergy between randomized history generation and `Delta` encodings. * By the same token, I have forgone shrinking — as long as they are no bugs, we don't need to shrink any. :) * `genChainHistory` generates random histories of `BlockHeader` with correct `parentHeaderHash`. Extending this to valid histories of `Block` in the future would allows us to test `UTxO` and address discovery state as well. [qsm]: https://well-typed.com/blog/2019/01/qsm-in-depth/ Co-authored-by: Heinrich Apfelmus <heinrich.apfelmus@iohk.io>
- Loading branch information
Showing
3 changed files
with
544 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,237 @@ | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE DeriveGeneric #-} | ||
| {-# LANGUAGE LambdaCase #-} | ||
| {-# LANGUAGE RankNTypes #-} | ||
| module Cardano.Wallet.Network.Light | ||
| ( -- * Interface | ||
| LightSyncSource (..) | ||
| , LightBlocks | ||
| , hoistLightSyncSource | ||
| , lightSync | ||
|
|
||
| , LightLayerLog (..) | ||
| ) where | ||
|
|
||
| import Prelude | ||
|
|
||
| import Cardano.BM.Data.Severity | ||
| ( Severity (..) ) | ||
| import Cardano.BM.Data.Tracer | ||
| ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) | ||
| import Cardano.Wallet.Network | ||
| ( ChainFollower (..) ) | ||
| import Cardano.Wallet.Primitive.BlockSummary | ||
| ( BlockSummary (..) ) | ||
| import Cardano.Wallet.Primitive.Types | ||
| ( BlockHeader (..) | ||
| , ChainPoint (..) | ||
| , chainPointFromBlockHeader | ||
| , compareSlot | ||
| ) | ||
| import Control.Monad.Class.MonadTimer | ||
| ( DiffTime, MonadDelay (..) ) | ||
| import Control.Tracer | ||
| ( Tracer, traceWith ) | ||
| import Data.List | ||
| ( maximumBy, sortBy ) | ||
| import Data.List.NonEmpty | ||
| ( NonEmpty (..) ) | ||
| import Data.Quantity | ||
| ( Quantity (..) ) | ||
| import Data.Text.Class | ||
| ( ToText (..) ) | ||
| import Data.Void | ||
| ( Void ) | ||
| import Data.Word | ||
| ( Word32 ) | ||
| import GHC.Generics | ||
| ( Generic ) | ||
|
|
||
| import qualified Data.List.NonEmpty as NE | ||
| import qualified Data.Text as T | ||
|
|
||
| {------------------------------------------------------------------------------- | ||
| LightLayer | ||
| -------------------------------------------------------------------------------} | ||
| type BlockHeight = Integer | ||
|
|
||
| -- | Blockchain data source suitable for the implementation of 'lightSync'. | ||
| data LightSyncSource m block addr txs = LightSyncSource | ||
| { stabilityWindow :: BlockHeight | ||
| -- ^ Stability window. | ||
| , getHeader :: block -> BlockHeader | ||
| -- ^ Get the 'BlockHeader' of a given @block@. | ||
| , getTip :: m BlockHeader | ||
| -- ^ Latest tip of the chain. | ||
| , isConsensus :: ChainPoint -> m Bool | ||
| -- ^ Check whether a 'ChainPoint' still exists in the consensus, | ||
| -- or whether the chain has rolled back already. | ||
| , getBlockHeaderAtHeight :: BlockHeight -> m (Maybe BlockHeader) | ||
| -- ^ Get the 'BlockHeader' at a given block height. | ||
| -- Returns 'Nothing' if there is no block at this height (anymore). | ||
| , getBlockHeaderAt :: ChainPoint -> m (Maybe BlockHeader) | ||
| -- ^ Get the full 'BlockHeader' belonging to a given 'ChainPoint'. | ||
| -- Return 'Nothing' if the point is not consensus anymore. | ||
| , getNextBlocks :: ChainPoint -> m (Maybe [block]) | ||
| -- ^ The the next blocks starting at the given 'Chainpoint'. | ||
| -- Return 'Nothing' if hte point is not consensus anymore. | ||
| , getAddressTxs :: BlockHeader -> BlockHeader -> addr -> m txs | ||
| -- ^ Transactions for a given address and point range. | ||
| } | ||
|
|
||
| hoistLightSyncSource | ||
| :: (forall a. m a -> n a) | ||
| -> LightSyncSource m block addr txs | ||
| -> LightSyncSource n block addr txs | ||
| hoistLightSyncSource f x = LightSyncSource | ||
| { stabilityWindow = stabilityWindow x | ||
| , getHeader = getHeader x | ||
| , getTip = f $ getTip x | ||
| , isConsensus = f . isConsensus x | ||
| , getBlockHeaderAtHeight = f . getBlockHeaderAtHeight x | ||
| , getBlockHeaderAt = f . getBlockHeaderAt x | ||
| , getNextBlocks = f . getNextBlocks x | ||
| , getAddressTxs = \a b c -> f $ getAddressTxs x a b c | ||
| } | ||
|
|
||
| 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 xs = maximumBy compareSlot xs | ||
|
|
||
| -- | Retrieve the 'ChainPoint' with the second-highest 'Slot'. | ||
| secondLatest :: [ChainPoint] -> ChainPoint | ||
| secondLatest [] = ChainPointAtGenesis | ||
| secondLatest [_] = ChainPointAtGenesis | ||
| secondLatest xs = head . tail $ sortBy (flip compareSlot) xs | ||
|
|
||
| -- | Drive a 'ChainFollower' using a 'LightSyncSource'. | ||
| -- Never returns. | ||
| lightSync | ||
| :: (Monad m, MonadDelay m) | ||
| => Tracer m LightLayerLog | ||
| -> LightSyncSource m block addr txs | ||
| -> ChainFollower m ChainPoint BlockHeader (LightBlocks m block addr txs) | ||
| -> m Void | ||
| lightSync tr light follower = do | ||
| pts <- readLocalTip follower | ||
| syncFrom $ latest pts | ||
| where | ||
| idle = threadDelay secondsPerSlot | ||
| syncFrom pt = do | ||
| move <- proceedToNextPoint light pt | ||
| syncFrom =<< case move of | ||
| Rollback -> do | ||
| prev <- secondLatest <$> readLocalTip follower | ||
| -- NOTE: Rolling back to a result of 'readLocalTip' | ||
| -- should always be possible, | ||
| -- but the code here does not need this assumption. | ||
| traceWith tr $ MsgLightRollBackward pt prev | ||
| rollBackward follower prev | ||
| Stable old new tip -> do | ||
| let summary = mkBlockSummary light old new | ||
| traceWith tr $ | ||
| MsgLightRollForward (chainPointFromBlockHeader old) new tip | ||
| rollForward follower (Right summary) tip | ||
| pure $ chainPointFromBlockHeader new | ||
| Unstable blocks new tip -> do | ||
| case blocks of | ||
| [] -> idle | ||
| (b:bs) -> do | ||
| traceWith tr $ MsgLightRollForward pt new tip | ||
| rollForward follower (Left $ b :| bs) tip | ||
| pure $ chainPointFromBlockHeader new | ||
|
|
||
| data NextPointMove block | ||
| = Rollback | ||
| -- ^ We are forced to roll back. | ||
| | Stable BlockHeader BlockHeader BlockHeader | ||
| -- ^ We are still in the stable region. | ||
| -- @Stable old new tip@. | ||
| | Unstable [block] BlockHeader BlockHeader | ||
| -- ^ We are entering the unstable region. | ||
| -- @Unstable blocks new tip@. | ||
|
|
||
| proceedToNextPoint | ||
| :: Monad m | ||
| => LightSyncSource m block addr txs | ||
| -> ChainPoint | ||
| -> m (NextPointMove block) | ||
| proceedToNextPoint light pt = do | ||
| tip <- getTip light | ||
| mold <- getBlockHeaderAt light pt | ||
| maybeRollback mold $ \old -> | ||
| if isUnstable (stabilityWindow light) old tip | ||
| then do | ||
| mblocks <- getNextBlocks light $ chainPointFromBlockHeader old | ||
| maybeRollback mblocks $ \case | ||
| [] -> pure $ Unstable [] old tip | ||
| (b:bs) -> do | ||
| let new = getHeader light $ NE.last (b :| bs) | ||
| continue <- isConsensus light $ chainPointFromBlockHeader new | ||
| pure $ if continue | ||
| then Unstable (b:bs) new tip | ||
| else Rollback | ||
| else do | ||
| mnew <- getBlockHeaderAtHeight light $ | ||
| blockHeightToInteger (blockHeight tip) - stabilityWindow light | ||
| maybeRollback mnew $ \new -> pure $ Stable old new tip | ||
| where | ||
| maybeRollback m f = maybe (pure Rollback) f m | ||
|
|
||
| -- | Test whether a 'ChainPoint' is in the | ||
| -- unstable region close to the tip. | ||
| isUnstable :: BlockHeight -> BlockHeader -> BlockHeader -> Bool | ||
| isUnstable stabilityWindow_ old tip = | ||
| blockHeightToInteger (blockHeight tip) - stabilityWindow_ | ||
| <= blockHeightToInteger (blockHeight old) | ||
|
|
||
| secondsPerSlot :: DiffTime | ||
| secondsPerSlot = 2 | ||
|
|
||
| -- | Create a 'BlockSummary' | ||
| mkBlockSummary | ||
| :: LightSyncSource m block addr txs | ||
| -> BlockHeader | ||
| -> BlockHeader | ||
| -> BlockSummary m addr txs | ||
| mkBlockSummary light old new = BlockSummary | ||
| { from = old | ||
| , to = new | ||
| , query = getAddressTxs light old new | ||
| } | ||
|
|
||
| blockHeightToInteger :: Quantity "block" Word32 -> Integer | ||
| blockHeightToInteger (Quantity n) = fromIntegral n | ||
|
|
||
| {------------------------------------------------------------------------------- | ||
| Logging | ||
| -------------------------------------------------------------------------------} | ||
| data LightLayerLog | ||
| = MsgLightRollForward ChainPoint BlockHeader BlockHeader | ||
| | MsgLightRollBackward ChainPoint ChainPoint | ||
| deriving (Show, Eq, Generic) | ||
|
|
||
| instance ToText LightLayerLog where | ||
| toText = \case | ||
| MsgLightRollForward from_ to_ tip -> T.unwords | ||
| [ "LightLayer roll forward:" | ||
| , "from: ", toText $ show from_ | ||
| , "to: ", toText $ show to_ | ||
| , "tip: ", toText $ show tip | ||
| ] | ||
| MsgLightRollBackward from_ to_ -> T.unwords | ||
| [ "LightLayer roll backward:" | ||
| , "from: ", toText $ show from_ | ||
| , "to: ", toText $ show to_ | ||
| ] | ||
|
|
||
| instance HasPrivacyAnnotation LightLayerLog | ||
|
|
||
| instance HasSeverityAnnotation LightLayerLog where | ||
| getSeverityAnnotation = \case | ||
| MsgLightRollForward{} -> Debug | ||
| MsgLightRollBackward{} -> Debug |
Oops, something went wrong.