content: {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE Rank2Types #-}
  
  module Cardano.Wallet.Network
      ( -- * Interface
        NetworkLayer (..)
  
        -- * Errors
      , ErrPostTx (..)
      , ErrFetchBlock (..)
  
        -- * Chain following
      , ChainFollower (..)
      , mapChainFollower
      , ChainFollowLog (..)
      , ChainSyncLog (..)
      , mapChainSyncLog
      , withFollowStatsMonitoring
  
        -- * Logging (for testing)
      , FollowStats (..)
      , Rearview (..)
      , emptyStats
      , updateStats
      ) where
  
  import Prelude
  
  import Cardano.Api
      ( AnyCardanoEra
      )
  import Cardano.Slotting.Slot
      ( SlotNo (..)
      )
  import Cardano.Wallet.Network.Checkpoints.Policy
      ( CheckpointPolicy
      )
  import Cardano.Wallet.Network.Logging
      ( ChainFollowLog (..)
      , ChainSyncLog (..)
      , FollowStats (..)
      , Rearview (..)
      , emptyStats
      , mapChainSyncLog
      , updateStats
      , withFollowStatsMonitoring
      )
  import Cardano.Wallet.Primitive.Slotting
      ( PastHorizonException
      , TimeInterpreter
      )
  import Cardano.Wallet.Primitive.SyncProgress
      ( SyncProgress (..)
      )
  import Cardano.Wallet.Primitive.Types.Coin
      ( Coin
      )
  import Cardano.Wallet.Primitive.Types.ProtocolParameters
      ( ProtocolParameters
      )
  import Cardano.Wallet.Primitive.Types.RewardAccount
      ( RewardAccount (..)
      )
  import Cardano.Wallet.Primitive.Types.SlottingParameters
      ( SlottingParameters
      )
  import Cardano.Wallet.Primitive.Types.StakePoolSummary
      ( StakePoolsSummary
      )
  import Cardano.Wallet.Primitive.Types.Tx.SealedTx
      ( SealedTx
      )
  import Cardano.Write.Eras
      ( MaybeInRecentEra
      )
  import Control.Monad.Trans.Except
      ( ExceptT (..)
      )
  import Control.Tracer
      ( Tracer
      )
  import Data.List.NonEmpty
      ( NonEmpty (..)
      )
  import Data.Map
      ( Map
      )
  import Data.Set
      ( Set
      )
  import Data.Text
      ( Text
      )
  import Data.Text.Class
      ( ToText (..)
      )
  import GHC.Generics
      ( Generic
      )
  
  import qualified Cardano.Wallet.Read as Read
  import qualified Data.Text as T
  import qualified Internal.Cardano.Write.Tx as Write
  
  {-----------------------------------------------------------------------------
      NetworkLayer
  ------------------------------------------------------------------------------}
  
  -- | Interface for network capabilities.
  data NetworkLayer m block = NetworkLayer
      { chainSync
          :: Tracer IO ChainFollowLog
          -> ChainFollower m Read.ChainPoint Read.ChainTip (NonEmpty block)
          -> m ()
      -- ^ Connect to the node and run the ChainSync protocol.
      -- The callbacks provided in the 'ChainFollower' argument
      -- are used to handle intersection finding,
      -- the arrival of new blocks, and rollbacks.
      , fetchNextBlock
          :: Read.ChainPoint
          -> m (Either ErrFetchBlock block)
      -- ^ Connect to the node,
      -- try to retrieve the block at a given 'ChainPoint',
      -- and close the connection again.
      , currentNodeTip
          :: m Read.ChainTip
      -- ^ Get the current tip from the chain producer
      , currentNodeEra
          :: m AnyCardanoEra
      -- ^ Get the era the node is currently in.
      , currentPParams
          :: m (Read.EraValue Read.PParams)
      -- ^ Get the last known protocol parameters. In principle, these can
      -- only change once per epoch.
      , currentProtocolParameters
          :: m ProtocolParameters
      -- ^ Get the last known protocol parameters. In principle, these can
      -- only change once per epoch.
      , currentSlottingParameters
          :: m SlottingParameters
      -- ^ Get the last known slotting parameters. In principle, these can
      -- only change once per era.
      , watchNodeTip
          :: (Read.ChainTip -> m ())
          -> m ()
      -- ^ Register a callback for when the node tip changes.
      -- This function should never finish, unless the callback throws an
      -- exception, which will be rethrown by this function.
      , postSealedTx
          :: SealedTx
          -> ExceptT ErrPostTx m ()
      -- ^ Broadcast a transaction to the chain producer (legacy types)
      , postTx
          :: forall era. Read.IsEra era
          => Read.Tx era
          -> ExceptT ErrPostTx m ()
      -- ^ Broadcast a transaction to the chain producer
      , stakeDistribution
          :: Coin -- Stake to consider for rewards
          -> m StakePoolsSummary
      , getUTxOByTxIn
          :: Set Write.TxIn
          -> m (MaybeInRecentEra Write.UTxO)
      , getStakeDelegDeposits
          :: Set Write.StakeCredential
          -> m (Map Write.StakeCredential Write.Coin)
      , getCachedRewardAccountBalance
          :: RewardAccount
          -- Either reward account from key hash or script hash
          -> m Coin
      -- ^ Return the cached reward balance of an account.
      --
      -- If there is no cached value, it will return `Coin 0`, and add the
      -- account to the internal set of observed account, such that it will be
      -- fetched later.
      , fetchRewardAccountBalances
          :: Set RewardAccount
          -> m (Map RewardAccount Coin)
      -- ^ Fetch the reward account balance of a set of accounts without
      -- any caching.
      , timeInterpreter
          :: TimeInterpreter (ExceptT PastHorizonException m)
      , syncProgress
          :: SlotNo
          -> m (SyncProgress)
      -- ^ Compute the ratio between the provided 'SlotNo' and the slot
      -- corresponding to the current wall-clock time.
      --
      -- Unlike using 'Cardano.Wallet.Primitive.SyncProgress.syncProgress'
      -- after retrieving a 'timeInterpreter', this function will return
      -- 'NotResponding' rather than block in the edge case when the era
      -- history has not yet been fetched from the node on startup.
      }
  
  instance Functor m => Functor (NetworkLayer m) where
      fmap f nl =
          nl
              { chainSync = \tr follower ->
                  chainSync nl tr $ mapChainFollower id id id (fmap f) follower
              , fetchNextBlock =
                  fmap (fmap f) . fetchNextBlock nl
              }
  
  {-----------------------------------------------------------------------------
      ChainFollower
  ------------------------------------------------------------------------------}
  
  -- | A collection of callbacks to use with the 'chainSync' function.
  data ChainFollower m point tip blocks = ChainFollower
      { checkpointPolicy :: Integer -> CheckpointPolicy
      -- ^ The policy for creating and pruning checkpoints that
      -- is used by the 'ChainFollower'.
      -- The argument of this field is the @epochStability@.
      --
      -- Exposing this policy here enables any chain synchronizer
      -- which does not retrieve full blocks, such as 'lightSync',
      -- to specifically target those block heights at which
      -- the 'ChainFollower' intends to create checkpoints.
      , readChainPoints :: m [point]
      -- ^ Callback for reading the local tip. Used to negotiate the
      -- intersection with the node.
      --
      -- A response of [] is interpreted as `Origin` -- i.e. the chain will be
      -- served from genesis.
      , rollForward :: blocks -> tip -> m ()
      -- ^ Callback for rolling forward.
      --
      -- Implementors _may_ delete old checkpoints while rolling forward.
      , rollBackward :: point -> m point
      -- ^ Roll back to the requested slot, or further, and return the point
      -- actually rolled back to.
      --
      -- __Example 1:__
      --
      -- If the follower stores checkpoints for all blocks, we can always roll
      -- back to the requested point exactly.
      --
      -- @
      -- -- If
      -- knownSlots follower `shouldReturn` [0,1,2,3]
      -- let requested = SlotNo 2
      -- -- Then
      -- actual <- rollBackward follower requested
      -- knownSlots follower shouldReturn` [0,1,2]
      -- actual `shouldBe` SlotNo 2
      -- @
      --
      -- Note that the slotNos are unlikely to be consecutive in real life,
      -- but this doesn't matter, as ouroboros-network asks us to rollback to
      -- points, corresponding to blocks.
      --
      -- __Example 2:__
      --
      -- @
      -- -- If
      -- knownSlots follower `shouldReturn` [0,9,10]
      -- let requested = SlotNo 2
      -- -- Then
      -- actual <- rollBackward follower requested
      -- knownSlots follower shouldReturn` [0]
      -- actual `shouldBe` SlotNo 0
      -- @
      }
  
  mapChainFollower
      :: Functor m
      => (point1 -> point2)
      -- ^ Covariant
      -> (point2 -> point1)
      -- ^ Contravariant
      -> (tip2 -> tip1)
      -- ^ Contravariant
      -> (blocks2 -> blocks1)
      -- ^ Contravariant
      -> ChainFollower m point1 tip1 blocks1
      -> ChainFollower m point2 tip2 blocks2
  mapChainFollower fpoint12 fpoint21 ftip fblocks cf =
      ChainFollower
          { checkpointPolicy = checkpointPolicy cf
          , readChainPoints = map fpoint12 <$> readChainPoints cf
          , rollForward = \bs tip -> rollForward cf (fblocks bs) (ftip tip)
          , rollBackward = fmap fpoint12 . rollBackward cf . fpoint21
          }
  
  {-------------------------------------------------------------------------------
      Errors
  -------------------------------------------------------------------------------}
  
  -- | Error while trying to send a transaction
  data ErrPostTx
      = ErrPostTxValidationError Text
      | ErrPostTxMempoolFull
      | ErrPostTxEraUnsupported (Read.EraValue Read.Era)
      deriving (Generic, Show, Eq)
  
  instance ToText ErrPostTx where
      toText = \case
          ErrPostTxValidationError msg -> msg
          ErrPostTxMempoolFull ->
              "mempool was full and refused posted transaction"
          ErrPostTxEraUnsupported (Read.EraValue unsupported) ->
              "Submitted transaction was in "
                  <> T.pack (show unsupported)
                  <> " era, which is not supported"
  
  -- | Error while trying to retrieve a block
  newtype ErrFetchBlock = ErrNoBlockAt Read.ChainPoint
      deriving (Generic, Show, Eq)
  
  instance ToText ErrFetchBlock where
      toText = \case
          ErrNoBlockAt pt ->
              "no block found at ChainPoint " <> T.pack (show pt)
  