{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

module Cardano.Wallet.Network.Light
    ( -- * Interface
      LightSyncSource (..)
    , LightBlocks
    , hoistLightSyncSource
    , lightSync
    , Consensual (..)
    , 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
    ( MonadDelay (..) )
import Control.Tracer
    ( Tracer, traceWith )
import Data.Functor
    ( ($>) )
import Data.List
    ( maximumBy, sortBy )
import Data.List.NonEmpty
    ( NonEmpty (..) )
import Data.Text.Class
    ( ToText (..) )
import Data.Void
    ( Void )
import Fmt
    ( Buildable (build), pretty )
import GHC.Generics
    ( Generic )

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
    { LightSyncSource m block addr txs -> block -> BlockHeader
getHeader :: block -> BlockHeader
        -- ^ Get the 'BlockHeader' of a given @block@.
    , LightSyncSource m block addr txs -> m BlockHeader
getTip :: m BlockHeader
        -- ^ Latest tip of the chain.
    , LightSyncSource m block addr txs
-> BlockHeight -> m (Consensual BlockHeader)
getBlockHeaderAtHeight :: BlockHeight -> m (Consensual BlockHeader)
        -- ^ Get the 'BlockHeader' at a given block height.
    , LightSyncSource m block addr txs
-> BlockHeader -> m (Consensual (Maybe BlockHeader))
getNextBlockHeader :: BlockHeader -> m (Consensual (Maybe BlockHeader))
        -- ^ Get the next block header.
    , LightSyncSource m block addr txs
-> ChainPoint -> m (Consensual BlockHeader)
getBlockHeaderAt :: ChainPoint -> m (Consensual BlockHeader)
        -- ^ Get the full 'BlockHeader' belonging to a given 'ChainPoint'.
        -- Return 'Nothing' if the point is not consensus anymore.
    , LightSyncSource m block addr txs
-> ChainPoint -> m (Consensual [block])
getNextBlocks :: ChainPoint -> m (Consensual [block])
        -- ^ Get several blocks immediately following the given 'Chainpoint'.
    , LightSyncSource m block addr txs
-> BlockHeader -> BlockHeader -> addr -> m txs
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 :: (forall a. m a -> n a)
-> LightSyncSource m block addr txs
-> LightSyncSource n block addr txs
hoistLightSyncSource forall a. m a -> n a
f LightSyncSource m block addr txs
x = LightSyncSource :: forall (m :: * -> *) block addr txs.
(block -> BlockHeader)
-> m BlockHeader
-> (BlockHeight -> m (Consensual BlockHeader))
-> (BlockHeader -> m (Consensual (Maybe BlockHeader)))
-> (ChainPoint -> m (Consensual BlockHeader))
-> (ChainPoint -> m (Consensual [block]))
-> (BlockHeader -> BlockHeader -> addr -> m txs)
-> LightSyncSource m block addr txs
LightSyncSource
    { getHeader :: block -> BlockHeader
getHeader = LightSyncSource m block addr txs -> block -> BlockHeader
forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs -> block -> BlockHeader
getHeader LightSyncSource m block addr txs
x
    , getTip :: n BlockHeader
getTip = m BlockHeader -> n BlockHeader
forall a. m a -> n a
f (m BlockHeader -> n BlockHeader) -> m BlockHeader -> n BlockHeader
forall a b. (a -> b) -> a -> b
$ LightSyncSource m block addr txs -> m BlockHeader
forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs -> m BlockHeader
getTip LightSyncSource m block addr txs
x
    , getBlockHeaderAtHeight :: BlockHeight -> n (Consensual BlockHeader)
getBlockHeaderAtHeight = m (Consensual BlockHeader) -> n (Consensual BlockHeader)
forall a. m a -> n a
f (m (Consensual BlockHeader) -> n (Consensual BlockHeader))
-> (BlockHeight -> m (Consensual BlockHeader))
-> BlockHeight
-> n (Consensual BlockHeader)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LightSyncSource m block addr txs
-> BlockHeight -> m (Consensual BlockHeader)
forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs
-> BlockHeight -> m (Consensual BlockHeader)
getBlockHeaderAtHeight LightSyncSource m block addr txs
x
    , getNextBlockHeader :: BlockHeader -> n (Consensual (Maybe BlockHeader))
getNextBlockHeader = m (Consensual (Maybe BlockHeader))
-> n (Consensual (Maybe BlockHeader))
forall a. m a -> n a
f (m (Consensual (Maybe BlockHeader))
 -> n (Consensual (Maybe BlockHeader)))
-> (BlockHeader -> m (Consensual (Maybe BlockHeader)))
-> BlockHeader
-> n (Consensual (Maybe BlockHeader))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LightSyncSource m block addr txs
-> BlockHeader -> m (Consensual (Maybe BlockHeader))
forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs
-> BlockHeader -> m (Consensual (Maybe BlockHeader))
getNextBlockHeader LightSyncSource m block addr txs
x
    , getBlockHeaderAt :: ChainPoint -> n (Consensual BlockHeader)
getBlockHeaderAt = m (Consensual BlockHeader) -> n (Consensual BlockHeader)
forall a. m a -> n a
f (m (Consensual BlockHeader) -> n (Consensual BlockHeader))
-> (ChainPoint -> m (Consensual BlockHeader))
-> ChainPoint
-> n (Consensual BlockHeader)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LightSyncSource m block addr txs
-> ChainPoint -> m (Consensual BlockHeader)
forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs
-> ChainPoint -> m (Consensual BlockHeader)
getBlockHeaderAt LightSyncSource m block addr txs
x
    , getNextBlocks :: ChainPoint -> n (Consensual [block])
getNextBlocks = m (Consensual [block]) -> n (Consensual [block])
forall a. m a -> n a
f (m (Consensual [block]) -> n (Consensual [block]))
-> (ChainPoint -> m (Consensual [block]))
-> ChainPoint
-> n (Consensual [block])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LightSyncSource m block addr txs
-> ChainPoint -> m (Consensual [block])
forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs
-> ChainPoint -> m (Consensual [block])
getNextBlocks LightSyncSource m block addr txs
x
    , getAddressTxs :: BlockHeader -> BlockHeader -> addr -> n txs
getAddressTxs = \BlockHeader
a BlockHeader
block addr
c -> m txs -> n txs
forall a. m a -> n a
f (m txs -> n txs) -> m txs -> n txs
forall a b. (a -> b) -> a -> b
$ LightSyncSource m block addr txs
-> BlockHeader -> BlockHeader -> addr -> m txs
forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs
-> BlockHeader -> BlockHeader -> addr -> m txs
getAddressTxs LightSyncSource m block addr txs
x BlockHeader
a BlockHeader
block addr
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 :: [ChainPoint] -> ChainPoint
latest [] = ChainPoint
ChainPointAtGenesis
latest [ChainPoint]
xs = (ChainPoint -> ChainPoint -> Ordering)
-> [ChainPoint] -> ChainPoint
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ChainPoint -> ChainPoint -> Ordering
compareSlot [ChainPoint]
xs

-- | Retrieve the 'ChainPoint' with the second-highest 'Slot'.
secondLatest :: [ChainPoint] -> ChainPoint
secondLatest :: [ChainPoint] -> ChainPoint
secondLatest []  = ChainPoint
ChainPointAtGenesis
secondLatest [ChainPoint
_] = ChainPoint
ChainPointAtGenesis
secondLatest [ChainPoint]
xs  = [ChainPoint] -> ChainPoint
forall a. [a] -> a
head ([ChainPoint] -> ChainPoint)
-> ([ChainPoint] -> [ChainPoint]) -> [ChainPoint] -> ChainPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChainPoint] -> [ChainPoint]
forall a. [a] -> [a]
tail ([ChainPoint] -> ChainPoint) -> [ChainPoint] -> ChainPoint
forall a b. (a -> b) -> a -> b
$ (ChainPoint -> ChainPoint -> Ordering)
-> [ChainPoint] -> [ChainPoint]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((ChainPoint -> ChainPoint -> Ordering)
-> ChainPoint -> ChainPoint -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip ChainPoint -> ChainPoint -> Ordering
compareSlot) [ChainPoint]
xs

-- | 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)
    -> m Void
lightSync :: Tracer m LightLayerLog
-> LightSyncSource m block addr txs
-> ChainFollower
     m ChainPoint BlockHeader (LightBlocks m block addr txs)
-> m Void
lightSync Tracer m LightLayerLog
tr LightSyncSource m block addr txs
light ChainFollower
  m ChainPoint BlockHeader (LightBlocks m block addr txs)
follower = ChainFollower
  m ChainPoint BlockHeader (LightBlocks m block addr txs)
-> m [ChainPoint]
forall (m :: * -> *) point tip blocks.
ChainFollower m point tip blocks -> m [point]
readChainPoints ChainFollower
  m ChainPoint BlockHeader (LightBlocks m block addr txs)
follower m [ChainPoint] -> ([ChainPoint] -> m Void) -> m Void
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChainPoint -> m Void
forall b. ChainPoint -> m b
syncFrom (ChainPoint -> m Void)
-> ([ChainPoint] -> ChainPoint) -> [ChainPoint] -> m Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChainPoint] -> ChainPoint
latest
  where
    syncFrom :: ChainPoint -> m b
syncFrom ChainPoint
chainPoint = do
        NextPointMove block
move <- LightSyncSource m block addr txs
-> ChainPoint -> m (NextPointMove block)
forall (m :: * -> *) block addr txs.
Monad m =>
LightSyncSource m block addr txs
-> ChainPoint -> m (NextPointMove block)
proceedToNextPoint LightSyncSource m block addr txs
light ChainPoint
chainPoint
        ChainPoint -> m b
syncFrom (ChainPoint -> m b) -> m ChainPoint -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case NextPointMove block
move of
            NextPointMove block
RollBackward -> do
                ChainPoint
prev <- [ChainPoint] -> ChainPoint
secondLatest ([ChainPoint] -> ChainPoint) -> m [ChainPoint] -> m ChainPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainFollower
  m ChainPoint BlockHeader (LightBlocks m block addr txs)
-> m [ChainPoint]
forall (m :: * -> *) point tip blocks.
ChainFollower m point tip blocks -> m [point]
readChainPoints ChainFollower
  m ChainPoint BlockHeader (LightBlocks m block addr txs)
follower
                -- NOTE: Rolling back to a result of 'readChainPoints'
                -- should always be possible,
                -- but the code currently does not need this assumption.
                Tracer m LightLayerLog -> LightLayerLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m LightLayerLog
tr (LightLayerLog -> m ()) -> LightLayerLog -> m ()
forall a b. (a -> b) -> a -> b
$ ChainPoint -> ChainPoint -> LightLayerLog
MsgLightRollBackward ChainPoint
chainPoint ChainPoint
prev
                ChainFollower
  m ChainPoint BlockHeader (LightBlocks m block addr txs)
-> ChainPoint -> m ChainPoint
forall (m :: * -> *) point tip blocks.
ChainFollower m point tip blocks -> point -> m point
rollBackward ChainFollower
  m ChainPoint BlockHeader (LightBlocks m block addr txs)
follower ChainPoint
prev
            RollForward BlockHeader
old BlockHeader
new BlockHeader
tip -> do
                Tracer m LightLayerLog -> LightLayerLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m LightLayerLog
tr (LightLayerLog -> m ()) -> LightLayerLog -> m ()
forall a b. (a -> b) -> a -> b
$ ChainPoint
-> BlockHeader -> BlockHeader -> BlockHeader -> LightLayerLog
MsgLightRollForward ChainPoint
chainPoint BlockHeader
old BlockHeader
new BlockHeader
tip
                ChainFollower
  m ChainPoint BlockHeader (LightBlocks m block addr txs)
-> LightBlocks m block addr txs -> BlockHeader -> m ()
forall (m :: * -> *) point tip blocks.
ChainFollower m point tip blocks -> blocks -> tip -> m ()
rollForward ChainFollower
  m ChainPoint BlockHeader (LightBlocks m block addr txs)
follower (BlockSummary m addr txs -> LightBlocks m block addr txs
forall a b. b -> Either a b
Right (BlockSummary m addr txs -> LightBlocks m block addr txs)
-> BlockSummary m addr txs -> LightBlocks m block addr txs
forall a b. (a -> b) -> a -> b
$ LightSyncSource m block addr txs
-> BlockHeader -> BlockHeader -> BlockSummary m addr txs
forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs
-> BlockHeader -> BlockHeader -> BlockSummary m addr txs
mkBlockSummary LightSyncSource m block addr txs
light BlockHeader
old BlockHeader
new) BlockHeader
tip
                Tracer m LightLayerLog -> LightLayerLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m LightLayerLog
tr (LightLayerLog -> m ()) -> LightLayerLog -> m ()
forall a b. (a -> b) -> a -> b
$ BlockHeader -> LightLayerLog
MsgLightRolledForward BlockHeader
new
                ChainPoint -> m ChainPoint
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainPoint -> m ChainPoint) -> ChainPoint -> m ChainPoint
forall a b. (a -> b) -> a -> b
$ BlockHeader -> ChainPoint
chainPointFromBlockHeader BlockHeader
new
            WaitForANewTip BlockHeader
tip -> do
                DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
2 -- seconds
                m () -> ChainPoint -> m ChainPoint
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BlockHeader -> ChainPoint
chainPointFromBlockHeader BlockHeader
tip

data NextPointMove block
    = RollForward
        BlockHeader
        -- ^ From
        BlockHeader
        -- ^ To
        BlockHeader
        -- ^ Tip
    | RollBackward
    | WaitForANewTip BlockHeader
    deriving (Int -> NextPointMove block -> ShowS
[NextPointMove block] -> ShowS
NextPointMove block -> String
(Int -> NextPointMove block -> ShowS)
-> (NextPointMove block -> String)
-> ([NextPointMove block] -> ShowS)
-> Show (NextPointMove block)
forall block. Int -> NextPointMove block -> ShowS
forall block. [NextPointMove block] -> ShowS
forall block. NextPointMove block -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NextPointMove block] -> ShowS
$cshowList :: forall block. [NextPointMove block] -> ShowS
show :: NextPointMove block -> String
$cshow :: forall block. NextPointMove block -> String
showsPrec :: Int -> NextPointMove block -> ShowS
$cshowsPrec :: forall block. Int -> NextPointMove block -> ShowS
Show)

-- | 'Consensual' represents the result of query on the blockchain.
-- Either the result is a value that is part of the consensus chain,
-- or the result is an indication that the consensus had changed
-- before the entire value could be retrieved.
data Consensual a
    = NotConsensual
    | Consensual a
    deriving stock (Consensual a -> Consensual a -> Bool
(Consensual a -> Consensual a -> Bool)
-> (Consensual a -> Consensual a -> Bool) -> Eq (Consensual a)
forall a. Eq a => Consensual a -> Consensual a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Consensual a -> Consensual a -> Bool
$c/= :: forall a. Eq a => Consensual a -> Consensual a -> Bool
== :: Consensual a -> Consensual a -> Bool
$c== :: forall a. Eq a => Consensual a -> Consensual a -> Bool
Eq, Int -> Consensual a -> ShowS
[Consensual a] -> ShowS
Consensual a -> String
(Int -> Consensual a -> ShowS)
-> (Consensual a -> String)
-> ([Consensual a] -> ShowS)
-> Show (Consensual a)
forall a. Show a => Int -> Consensual a -> ShowS
forall a. Show a => [Consensual a] -> ShowS
forall a. Show a => Consensual a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Consensual a] -> ShowS
$cshowList :: forall a. Show a => [Consensual a] -> ShowS
show :: Consensual a -> String
$cshow :: forall a. Show a => Consensual a -> String
showsPrec :: Int -> Consensual a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Consensual a -> ShowS
Show, a -> Consensual b -> Consensual a
(a -> b) -> Consensual a -> Consensual b
(forall a b. (a -> b) -> Consensual a -> Consensual b)
-> (forall a b. a -> Consensual b -> Consensual a)
-> Functor Consensual
forall a b. a -> Consensual b -> Consensual a
forall a b. (a -> b) -> Consensual a -> Consensual b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Consensual b -> Consensual a
$c<$ :: forall a b. a -> Consensual b -> Consensual a
fmap :: (a -> b) -> Consensual a -> Consensual b
$cfmap :: forall a b. (a -> b) -> Consensual a -> Consensual b
Functor, Consensual a -> Bool
(a -> m) -> Consensual a -> m
(a -> b -> b) -> b -> Consensual a -> b
(forall m. Monoid m => Consensual m -> m)
-> (forall m a. Monoid m => (a -> m) -> Consensual a -> m)
-> (forall m a. Monoid m => (a -> m) -> Consensual a -> m)
-> (forall a b. (a -> b -> b) -> b -> Consensual a -> b)
-> (forall a b. (a -> b -> b) -> b -> Consensual a -> b)
-> (forall b a. (b -> a -> b) -> b -> Consensual a -> b)
-> (forall b a. (b -> a -> b) -> b -> Consensual a -> b)
-> (forall a. (a -> a -> a) -> Consensual a -> a)
-> (forall a. (a -> a -> a) -> Consensual a -> a)
-> (forall a. Consensual a -> [a])
-> (forall a. Consensual a -> Bool)
-> (forall a. Consensual a -> Int)
-> (forall a. Eq a => a -> Consensual a -> Bool)
-> (forall a. Ord a => Consensual a -> a)
-> (forall a. Ord a => Consensual a -> a)
-> (forall a. Num a => Consensual a -> a)
-> (forall a. Num a => Consensual a -> a)
-> Foldable Consensual
forall a. Eq a => a -> Consensual a -> Bool
forall a. Num a => Consensual a -> a
forall a. Ord a => Consensual a -> a
forall m. Monoid m => Consensual m -> m
forall a. Consensual a -> Bool
forall a. Consensual a -> Int
forall a. Consensual a -> [a]
forall a. (a -> a -> a) -> Consensual a -> a
forall m a. Monoid m => (a -> m) -> Consensual a -> m
forall b a. (b -> a -> b) -> b -> Consensual a -> b
forall a b. (a -> b -> b) -> b -> Consensual a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Consensual a -> a
$cproduct :: forall a. Num a => Consensual a -> a
sum :: Consensual a -> a
$csum :: forall a. Num a => Consensual a -> a
minimum :: Consensual a -> a
$cminimum :: forall a. Ord a => Consensual a -> a
maximum :: Consensual a -> a
$cmaximum :: forall a. Ord a => Consensual a -> a
elem :: a -> Consensual a -> Bool
$celem :: forall a. Eq a => a -> Consensual a -> Bool
length :: Consensual a -> Int
$clength :: forall a. Consensual a -> Int
null :: Consensual a -> Bool
$cnull :: forall a. Consensual a -> Bool
toList :: Consensual a -> [a]
$ctoList :: forall a. Consensual a -> [a]
foldl1 :: (a -> a -> a) -> Consensual a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Consensual a -> a
foldr1 :: (a -> a -> a) -> Consensual a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Consensual a -> a
foldl' :: (b -> a -> b) -> b -> Consensual a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Consensual a -> b
foldl :: (b -> a -> b) -> b -> Consensual a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Consensual a -> b
foldr' :: (a -> b -> b) -> b -> Consensual a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Consensual a -> b
foldr :: (a -> b -> b) -> b -> Consensual a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Consensual a -> b
foldMap' :: (a -> m) -> Consensual a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Consensual a -> m
foldMap :: (a -> m) -> Consensual a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Consensual a -> m
fold :: Consensual m -> m
$cfold :: forall m. Monoid m => Consensual m -> m
Foldable, Functor Consensual
Foldable Consensual
Functor Consensual
-> Foldable Consensual
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Consensual a -> f (Consensual b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Consensual (f a) -> f (Consensual a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Consensual a -> m (Consensual b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Consensual (m a) -> m (Consensual a))
-> Traversable Consensual
(a -> f b) -> Consensual a -> f (Consensual b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
Consensual (m a) -> m (Consensual a)
forall (f :: * -> *) a.
Applicative f =>
Consensual (f a) -> f (Consensual a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Consensual a -> m (Consensual b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Consensual a -> f (Consensual b)
sequence :: Consensual (m a) -> m (Consensual a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Consensual (m a) -> m (Consensual a)
mapM :: (a -> m b) -> Consensual a -> m (Consensual b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Consensual a -> m (Consensual b)
sequenceA :: Consensual (f a) -> f (Consensual a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Consensual (f a) -> f (Consensual a)
traverse :: (a -> f b) -> Consensual a -> f (Consensual b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Consensual a -> f (Consensual b)
$cp2Traversable :: Foldable Consensual
$cp1Traversable :: Functor Consensual
Traversable)

instance Buildable a => Buildable (Consensual a) where
  build :: Consensual a -> Builder
build = \case
    Consensual a
NotConsensual -> Builder
"NotConsensual"
    Consensual a
a -> Builder
"Consensual " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall p. Buildable p => p -> Builder
build a
a

consensually
    :: Applicative m
    => (a -> m (NextPointMove block))
    -> Consensual a
    -> m (NextPointMove block)
consensually :: (a -> m (NextPointMove block))
-> Consensual a -> m (NextPointMove block)
consensually a -> m (NextPointMove block)
k Consensual a
ca =
    case Consensual a
ca of
        Consensual a
NotConsensual-> NextPointMove block -> m (NextPointMove block)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NextPointMove block
forall block. NextPointMove block
RollBackward
        Consensual a
a -> a -> m (NextPointMove block)
k a
a

proceedToNextPoint
    :: Monad m
    => LightSyncSource m block addr txs
    -> ChainPoint
    -> m (NextPointMove block)
proceedToNextPoint :: LightSyncSource m block addr txs
-> ChainPoint -> m (NextPointMove block)
proceedToNextPoint LightSyncSource{m BlockHeader
block -> BlockHeader
BlockHeight -> m (Consensual BlockHeader)
ChainPoint -> m (Consensual [block])
ChainPoint -> m (Consensual BlockHeader)
BlockHeader -> m (Consensual (Maybe BlockHeader))
BlockHeader -> BlockHeader -> addr -> m txs
getAddressTxs :: BlockHeader -> BlockHeader -> addr -> m txs
getNextBlocks :: ChainPoint -> m (Consensual [block])
getBlockHeaderAt :: ChainPoint -> m (Consensual BlockHeader)
getNextBlockHeader :: BlockHeader -> m (Consensual (Maybe BlockHeader))
getBlockHeaderAtHeight :: BlockHeight -> m (Consensual BlockHeader)
getTip :: m BlockHeader
getHeader :: block -> BlockHeader
getAddressTxs :: forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs
-> BlockHeader -> BlockHeader -> addr -> m txs
getNextBlocks :: forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs
-> ChainPoint -> m (Consensual [block])
getBlockHeaderAt :: forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs
-> ChainPoint -> m (Consensual BlockHeader)
getNextBlockHeader :: forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs
-> BlockHeader -> m (Consensual (Maybe BlockHeader))
getBlockHeaderAtHeight :: forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs
-> BlockHeight -> m (Consensual BlockHeader)
getTip :: forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs -> m BlockHeader
getHeader :: forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs -> block -> BlockHeader
..} ChainPoint
chainPoint =
    ChainPoint -> m (Consensual BlockHeader)
getBlockHeaderAt ChainPoint
chainPoint m (Consensual BlockHeader)
-> (Consensual BlockHeader -> m (NextPointMove block))
-> m (NextPointMove block)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (BlockHeader -> m (NextPointMove block))
-> Consensual BlockHeader -> m (NextPointMove block)
forall (m :: * -> *) a block.
Applicative m =>
(a -> m (NextPointMove block))
-> Consensual a -> m (NextPointMove block)
consensually \BlockHeader
currentBlock ->
        BlockHeader -> m (Consensual (Maybe BlockHeader))
getNextBlockHeader BlockHeader
currentBlock m (Consensual (Maybe BlockHeader))
-> (Consensual (Maybe BlockHeader) -> m (NextPointMove block))
-> m (NextPointMove block)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe BlockHeader -> m (NextPointMove block))
-> Consensual (Maybe BlockHeader) -> m (NextPointMove block)
forall (m :: * -> *) a block.
Applicative m =>
(a -> m (NextPointMove block))
-> Consensual a -> m (NextPointMove block)
consensually \case
            Maybe BlockHeader
Nothing -> NextPointMove block -> m (NextPointMove block)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NextPointMove block -> m (NextPointMove block))
-> NextPointMove block -> m (NextPointMove block)
forall a b. (a -> b) -> a -> b
$ BlockHeader -> NextPointMove block
forall block. BlockHeader -> NextPointMove block
WaitForANewTip BlockHeader
currentBlock
            Just BlockHeader
fromBlock -> do
                BlockHeader
chainTip <- m BlockHeader
getTip
                -- In some rare cases a rollback happens on the blockchain
                -- in between the getNextBlockHeader and getTip
                -- and the tip is behind the next block. We don't want to
                -- roll forward in this case, so we additionally check that
                -- we only roll forward if the block height is growing.
                --
                -- FIXME later: This criterion is not foolproof —
                -- it is possible for the tip to gain higher block height even
                -- after a rollback. For now, we accept this rare risk.
                -- Note: The invariant that we (eventually) want to preserve
                -- is that all block headers in `RollForward` are consistent
                -- with a potential history of the blockchain.
                -- (The headers do not need to consensus at the time
                -- of the roll forward, but they do need to be consistent
                -- with each other.)
                NextPointMove block -> m (NextPointMove block)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    if BlockHeader -> Quantity "block" Word32
blockHeight BlockHeader
fromBlock Quantity "block" Word32 -> Quantity "block" Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockHeader -> Quantity "block" Word32
blockHeight BlockHeader
chainTip
                    then BlockHeader -> BlockHeader -> BlockHeader -> NextPointMove block
forall block.
BlockHeader -> BlockHeader -> BlockHeader -> NextPointMove block
RollForward BlockHeader
fromBlock BlockHeader
chainTip BlockHeader
chainTip
                    else NextPointMove block
forall block. NextPointMove block
RollBackward

-- | Create a 'BlockSummary'
mkBlockSummary
    :: LightSyncSource m block addr txs
    -> BlockHeader
    -> BlockHeader
    -> BlockSummary m addr txs
mkBlockSummary :: LightSyncSource m block addr txs
-> BlockHeader -> BlockHeader -> BlockSummary m addr txs
mkBlockSummary LightSyncSource m block addr txs
light BlockHeader
old BlockHeader
new = BlockSummary :: forall (m :: * -> *) addr txs.
BlockHeader
-> BlockHeader -> (addr -> m txs) -> BlockSummary m addr txs
BlockSummary
    { $sel:from:BlockSummary :: BlockHeader
from = BlockHeader
old
    , $sel:to:BlockSummary :: BlockHeader
to = BlockHeader
new
    , $sel:query:BlockSummary :: addr -> m txs
query = LightSyncSource m block addr txs
-> BlockHeader -> BlockHeader -> addr -> m txs
forall (m :: * -> *) block addr txs.
LightSyncSource m block addr txs
-> BlockHeader -> BlockHeader -> addr -> m txs
getAddressTxs LightSyncSource m block addr txs
light BlockHeader
old BlockHeader
new
    }

{-------------------------------------------------------------------------------
    Logging
-------------------------------------------------------------------------------}
data LightLayerLog
    = MsgLightRollForward
        ChainPoint BlockHeader BlockHeader BlockHeader
    | MsgLightRolledForward BlockHeader
    | MsgLightRollBackward
        ChainPoint ChainPoint
    deriving (Int -> LightLayerLog -> ShowS
[LightLayerLog] -> ShowS
LightLayerLog -> String
(Int -> LightLayerLog -> ShowS)
-> (LightLayerLog -> String)
-> ([LightLayerLog] -> ShowS)
-> Show LightLayerLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LightLayerLog] -> ShowS
$cshowList :: [LightLayerLog] -> ShowS
show :: LightLayerLog -> String
$cshow :: LightLayerLog -> String
showsPrec :: Int -> LightLayerLog -> ShowS
$cshowsPrec :: Int -> LightLayerLog -> ShowS
Show, LightLayerLog -> LightLayerLog -> Bool
(LightLayerLog -> LightLayerLog -> Bool)
-> (LightLayerLog -> LightLayerLog -> Bool) -> Eq LightLayerLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LightLayerLog -> LightLayerLog -> Bool
$c/= :: LightLayerLog -> LightLayerLog -> Bool
== :: LightLayerLog -> LightLayerLog -> Bool
$c== :: LightLayerLog -> LightLayerLog -> Bool
Eq, (forall x. LightLayerLog -> Rep LightLayerLog x)
-> (forall x. Rep LightLayerLog x -> LightLayerLog)
-> Generic LightLayerLog
forall x. Rep LightLayerLog x -> LightLayerLog
forall x. LightLayerLog -> Rep LightLayerLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LightLayerLog x -> LightLayerLog
$cfrom :: forall x. LightLayerLog -> Rep LightLayerLog x
Generic)

instance ToText LightLayerLog where
    toText :: LightLayerLog -> Text
toText = \case
        MsgLightRollForward ChainPoint
cp_ BlockHeader
from_ BlockHeader
to_ BlockHeader
tip ->
            [Text] -> Text
T.unwords
                [ Text
"LightLayer started rolling forward:"
                , Text
"chain_point: ", ChainPoint -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ChainPoint
cp_
                , Text
"from: ", BlockHeader -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty BlockHeader
from_
                , Text
"to: ", BlockHeader -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty BlockHeader
to_
                , Text
"tip: ", BlockHeader -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty BlockHeader
tip
                ]
        MsgLightRolledForward BlockHeader
bh ->
            [Text] -> Text
T.unwords
                [ Text
"LightLayer finished rolling forward:"
                , Text
"last block: ", BlockHeader -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty BlockHeader
bh
                ]
        MsgLightRollBackward ChainPoint
from_ ChainPoint
to_ ->
            [Text] -> Text
T.unwords
                [ Text
"LightLayer roll backward:"
                , Text
"from: ", ChainPoint -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ChainPoint
from_
                , Text
"to: ", ChainPoint -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ChainPoint
to_
                ]

instance HasPrivacyAnnotation LightLayerLog

instance HasSeverityAnnotation LightLayerLog where
    getSeverityAnnotation :: LightLayerLog -> Severity
getSeverityAnnotation = \case
        MsgLightRollForward{} -> Severity
Debug
        MsgLightRolledForward{} -> Severity
Debug
        MsgLightRollBackward{} -> Severity
Debug