{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
{-# LANGUAGE GADTs      #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
module Cardano.Streaming.Helpers where

import Control.Concurrent.Async qualified as IO
import Control.Exception qualified as IO
import Data.SOP.Strict (NP ((:*)))
import GHC.Generics (Generic)
import Streaming.Prelude qualified as S

import Cardano.Api qualified as C
import Cardano.Api.Shelley qualified as CS
import Cardano.Chain.Genesis qualified
import Cardano.Crypto (ProtocolMagicId (unProtocolMagicId), RequiresNetworkMagic (RequiresMagic, RequiresNoMagic))
import Cardano.Ledger.Shelley.LedgerState qualified as SL
import Cardano.Slotting.Slot (WithOrigin (At, Origin))
import Ouroboros.Consensus.Cardano.Block qualified as O
import Ouroboros.Consensus.Cardano.CanHardFork qualified as Consensus
import Ouroboros.Consensus.HardFork.Combinator qualified as Consensus
import Ouroboros.Consensus.HardFork.Combinator.AcrossEras qualified as HFC
import Ouroboros.Consensus.HardFork.Combinator.Basics qualified as HFC
import Ouroboros.Consensus.Shelley.Ledger qualified as O

-- * ChainSyncEvent

data ChainSyncEvent a
  = RollForward a C.ChainTip
  | RollBackward C.ChainPoint C.ChainTip
  deriving (Int -> ChainSyncEvent a -> ShowS
[ChainSyncEvent a] -> ShowS
ChainSyncEvent a -> String
(Int -> ChainSyncEvent a -> ShowS)
-> (ChainSyncEvent a -> String)
-> ([ChainSyncEvent a] -> ShowS)
-> Show (ChainSyncEvent a)
forall a. Show a => Int -> ChainSyncEvent a -> ShowS
forall a. Show a => [ChainSyncEvent a] -> ShowS
forall a. Show a => ChainSyncEvent a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainSyncEvent a] -> ShowS
$cshowList :: forall a. Show a => [ChainSyncEvent a] -> ShowS
show :: ChainSyncEvent a -> String
$cshow :: forall a. Show a => ChainSyncEvent a -> String
showsPrec :: Int -> ChainSyncEvent a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ChainSyncEvent a -> ShowS
Show, a -> ChainSyncEvent b -> ChainSyncEvent a
(a -> b) -> ChainSyncEvent a -> ChainSyncEvent b
(forall a b. (a -> b) -> ChainSyncEvent a -> ChainSyncEvent b)
-> (forall a b. a -> ChainSyncEvent b -> ChainSyncEvent a)
-> Functor ChainSyncEvent
forall a b. a -> ChainSyncEvent b -> ChainSyncEvent a
forall a b. (a -> b) -> ChainSyncEvent a -> ChainSyncEvent b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ChainSyncEvent b -> ChainSyncEvent a
$c<$ :: forall a b. a -> ChainSyncEvent b -> ChainSyncEvent a
fmap :: (a -> b) -> ChainSyncEvent a -> ChainSyncEvent b
$cfmap :: forall a b. (a -> b) -> ChainSyncEvent a -> ChainSyncEvent b
Functor, (forall x. ChainSyncEvent a -> Rep (ChainSyncEvent a) x)
-> (forall x. Rep (ChainSyncEvent a) x -> ChainSyncEvent a)
-> Generic (ChainSyncEvent a)
forall x. Rep (ChainSyncEvent a) x -> ChainSyncEvent a
forall x. ChainSyncEvent a -> Rep (ChainSyncEvent a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ChainSyncEvent a) x -> ChainSyncEvent a
forall a x. ChainSyncEvent a -> Rep (ChainSyncEvent a) x
$cto :: forall a x. Rep (ChainSyncEvent a) x -> ChainSyncEvent a
$cfrom :: forall a x. ChainSyncEvent a -> Rep (ChainSyncEvent a) x
Generic)

data ChainSyncEventException
  = NoIntersectionFound
  deriving (Int -> ChainSyncEventException -> ShowS
[ChainSyncEventException] -> ShowS
ChainSyncEventException -> String
(Int -> ChainSyncEventException -> ShowS)
-> (ChainSyncEventException -> String)
-> ([ChainSyncEventException] -> ShowS)
-> Show ChainSyncEventException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainSyncEventException] -> ShowS
$cshowList :: [ChainSyncEventException] -> ShowS
show :: ChainSyncEventException -> String
$cshow :: ChainSyncEventException -> String
showsPrec :: Int -> ChainSyncEventException -> ShowS
$cshowsPrec :: Int -> ChainSyncEventException -> ShowS
Show)

instance IO.Exception ChainSyncEventException

data RollbackException = RollbackLocationNotFound C.ChainPoint C.ChainTip
  deriving (RollbackException -> RollbackException -> Bool
(RollbackException -> RollbackException -> Bool)
-> (RollbackException -> RollbackException -> Bool)
-> Eq RollbackException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RollbackException -> RollbackException -> Bool
$c/= :: RollbackException -> RollbackException -> Bool
== :: RollbackException -> RollbackException -> Bool
$c== :: RollbackException -> RollbackException -> Bool
Eq, Int -> RollbackException -> ShowS
[RollbackException] -> ShowS
RollbackException -> String
(Int -> RollbackException -> ShowS)
-> (RollbackException -> String)
-> ([RollbackException] -> ShowS)
-> Show RollbackException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RollbackException] -> ShowS
$cshowList :: [RollbackException] -> ShowS
show :: RollbackException -> String
$cshow :: RollbackException -> String
showsPrec :: Int -> RollbackException -> ShowS
$cshowsPrec :: Int -> RollbackException -> ShowS
Show)
instance IO.Exception RollbackException

-- * Orphans

instance IO.Exception C.LedgerStateError

instance IO.Exception C.FoldBlocksError
deriving instance Show C.FoldBlocksError

instance IO.Exception C.InitialLedgerStateError
deriving instance Show C.InitialLedgerStateError
deriving instance Show CS.GenesisConfigError

-- * Block

bimBlockNo :: C.BlockInMode C.CardanoMode -> C.BlockNo
bimBlockNo :: BlockInMode CardanoMode -> BlockNo
bimBlockNo (C.BlockInMode (C.Block (C.BlockHeader SlotNo
_ Hash BlockHeader
_ BlockNo
blockNo) [Tx era]
_) EraInMode era CardanoMode
_) = BlockNo
blockNo

bimSlotNo :: C.BlockInMode C.CardanoMode -> C.SlotNo
bimSlotNo :: BlockInMode CardanoMode -> SlotNo
bimSlotNo (C.BlockInMode (C.Block (C.BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
_) [Tx era]
_) EraInMode era CardanoMode
_) = SlotNo
slotNo

getEpochNo :: C.LedgerState -> Maybe CS.EpochNo
getEpochNo :: LedgerState -> Maybe EpochNo
getEpochNo LedgerState
ledgerState' = case LedgerState
ledgerState' of
  C.LedgerStateByron LedgerState ByronBlock
_st                   -> Maybe EpochNo
forall a. Maybe a
Nothing
  C.LedgerStateShelley LedgerState (ShelleyBlock protocol (ShelleyEra StandardCrypto))
st                  -> LedgerState (ShelleyBlock protocol (ShelleyEra StandardCrypto))
-> Maybe EpochNo
forall proto era.
LedgerState (ShelleyBlock proto era) -> Maybe EpochNo
fromState LedgerState (ShelleyBlock protocol (ShelleyEra StandardCrypto))
st
  C.LedgerStateAllegra LedgerState (ShelleyBlock protocol (AllegraEra StandardCrypto))
st                  -> LedgerState (ShelleyBlock protocol (AllegraEra StandardCrypto))
-> Maybe EpochNo
forall proto era.
LedgerState (ShelleyBlock proto era) -> Maybe EpochNo
fromState LedgerState (ShelleyBlock protocol (AllegraEra StandardCrypto))
st
  C.LedgerStateMary LedgerState (ShelleyBlock protocol (MaryEra StandardCrypto))
st                     -> LedgerState (ShelleyBlock protocol (MaryEra StandardCrypto))
-> Maybe EpochNo
forall proto era.
LedgerState (ShelleyBlock proto era) -> Maybe EpochNo
fromState LedgerState (ShelleyBlock protocol (MaryEra StandardCrypto))
st
  C.LedgerStateAlonzo LedgerState (ShelleyBlock protocol (AlonzoEra StandardCrypto))
st                   -> LedgerState (ShelleyBlock protocol (AlonzoEra StandardCrypto))
-> Maybe EpochNo
forall proto era.
LedgerState (ShelleyBlock proto era) -> Maybe EpochNo
fromState LedgerState (ShelleyBlock protocol (AlonzoEra StandardCrypto))
st
  CS.LedgerState (O.LedgerStateBabbage LedgerState
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
st) -> LedgerState
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
-> Maybe EpochNo
forall proto era.
LedgerState (ShelleyBlock proto era) -> Maybe EpochNo
fromState LedgerState
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
st -- TODO pattern missing from cardano-node: is it there on master? if not create PR.
  where
    fromState :: LedgerState (ShelleyBlock proto era) -> Maybe EpochNo
fromState = EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just (EpochNo -> Maybe EpochNo)
-> (LedgerState (ShelleyBlock proto era) -> EpochNo)
-> LedgerState (ShelleyBlock proto era)
-> Maybe EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> EpochNo
forall era. NewEpochState era -> EpochNo
SL.nesEL (NewEpochState era -> EpochNo)
-> (LedgerState (ShelleyBlock proto era) -> NewEpochState era)
-> LedgerState (ShelleyBlock proto era)
-> EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
O.shelleyLedgerState

fromChainTip :: C.ChainTip -> WithOrigin C.BlockNo
fromChainTip :: ChainTip -> WithOrigin BlockNo
fromChainTip ChainTip
ct = case ChainTip
ct of
  ChainTip
C.ChainTipAtGenesis -> WithOrigin BlockNo
forall t. WithOrigin t
Origin
  C.ChainTip SlotNo
_ Hash BlockHeader
_ BlockNo
bno  -> BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At BlockNo
bno

-- * IO

linkedAsync :: IO a -> IO ()
linkedAsync :: IO a -> IO ()
linkedAsync IO a
action = Async a -> IO ()
forall a. Async a -> IO ()
IO.link (Async a -> IO ()) -> IO (Async a) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
IO.async IO a
action

-- * LocalNodeConnectInfo

mkLocalNodeConnectInfo :: C.NetworkId -> FilePath -> C.LocalNodeConnectInfo C.CardanoMode
mkLocalNodeConnectInfo :: NetworkId -> String -> LocalNodeConnectInfo CardanoMode
mkLocalNodeConnectInfo NetworkId
networkId String
socketPath = LocalNodeConnectInfo :: forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
C.LocalNodeConnectInfo
  { localConsensusModeParams :: ConsensusModeParams CardanoMode
C.localConsensusModeParams = EpochSlots -> ConsensusModeParams CardanoMode
C.CardanoModeParams EpochSlots
epochSlots
  , localNodeNetworkId :: NetworkId
C.localNodeNetworkId = NetworkId
networkId
  , localNodeSocketPath :: String
C.localNodeSocketPath = String
socketPath
  }
  -- This a parameter needed only for the Byron era. Since the Byron
  -- era is over and the parameter has never changed it is ok to
  -- hardcode this. See comment on `Cardano.Api.ConsensusModeParams` in
  -- cardano-node.
  where epochSlots :: EpochSlots
epochSlots = Word64 -> EpochSlots
C.EpochSlots Word64
21600 -- TODO: is this configurable? see below

-- | Derive LocalNodeConnectInfo from Env.
mkConnectInfo :: C.Env -> FilePath -> C.LocalNodeConnectInfo C.CardanoMode
mkConnectInfo :: Env -> String -> LocalNodeConnectInfo CardanoMode
mkConnectInfo Env
env String
socketPath = LocalNodeConnectInfo :: forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
C.LocalNodeConnectInfo
  { localConsensusModeParams :: ConsensusModeParams CardanoMode
C.localConsensusModeParams = ConsensusModeParams CardanoMode
cardanoModeParams
  , localNodeNetworkId :: NetworkId
C.localNodeNetworkId       = NetworkId
networkId'
  , localNodeSocketPath :: String
C.localNodeSocketPath      = String
socketPath
  }
  where
    -- Derive the NetworkId as described in network-magic.md from the
    -- cardano-ledger-specs repo.
    byronConfig :: Config
byronConfig
      = (\(Consensus.WrapPartialLedgerConfig (Consensus.ByronPartialLedgerConfig bc _) :* NP WrapPartialLedgerConfig xs
_) -> Config
LedgerConfig ByronBlock
bc)
      (NP WrapPartialLedgerConfig (CardanoEras StandardCrypto) -> Config)
-> (HardForkLedgerConfig (CardanoEras StandardCrypto)
    -> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto))
-> HardForkLedgerConfig (CardanoEras StandardCrypto)
-> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerEraLedgerConfig (CardanoEras StandardCrypto)
-> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto)
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
HFC.getPerEraLedgerConfig
      (PerEraLedgerConfig (CardanoEras StandardCrypto)
 -> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto))
-> (HardForkLedgerConfig (CardanoEras StandardCrypto)
    -> PerEraLedgerConfig (CardanoEras StandardCrypto))
-> HardForkLedgerConfig (CardanoEras StandardCrypto)
-> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkLedgerConfig (CardanoEras StandardCrypto)
-> PerEraLedgerConfig (CardanoEras StandardCrypto)
forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
HFC.hardForkLedgerConfigPerEra
      (HardForkLedgerConfig (CardanoEras StandardCrypto) -> Config)
-> HardForkLedgerConfig (CardanoEras StandardCrypto) -> Config
forall a b. (a -> b) -> a -> b
$ Env -> HardForkLedgerConfig (CardanoEras StandardCrypto)
C.envLedgerConfig Env
env

    networkMagic :: NetworkMagic
networkMagic
      = Word32 -> NetworkMagic
C.NetworkMagic
      (Word32 -> NetworkMagic) -> Word32 -> NetworkMagic
forall a b. (a -> b) -> a -> b
$ ProtocolMagicId -> Word32
unProtocolMagicId
      (ProtocolMagicId -> Word32) -> ProtocolMagicId -> Word32
forall a b. (a -> b) -> a -> b
$ GenesisData -> ProtocolMagicId
Cardano.Chain.Genesis.gdProtocolMagicId
      (GenesisData -> ProtocolMagicId) -> GenesisData -> ProtocolMagicId
forall a b. (a -> b) -> a -> b
$ Config -> GenesisData
Cardano.Chain.Genesis.configGenesisData Config
byronConfig

    networkId' :: NetworkId
networkId' = case Config -> RequiresNetworkMagic
Cardano.Chain.Genesis.configReqNetMagic Config
byronConfig of
      RequiresNetworkMagic
RequiresNoMagic -> NetworkId
C.Mainnet
      RequiresNetworkMagic
RequiresMagic   -> NetworkMagic -> NetworkId
C.Testnet NetworkMagic
networkMagic

    cardanoModeParams :: ConsensusModeParams CardanoMode
cardanoModeParams = EpochSlots -> ConsensusModeParams CardanoMode
C.CardanoModeParams (EpochSlots -> ConsensusModeParams CardanoMode)
-> (Word64 -> EpochSlots)
-> Word64
-> ConsensusModeParams CardanoMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> EpochSlots
C.EpochSlots (Word64 -> ConsensusModeParams CardanoMode)
-> Word64 -> ConsensusModeParams CardanoMode
forall a b. (a -> b) -> a -> b
$ Word64
10 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Env -> Word64
C.envSecurityParam Env
env

-- | Ignore rollback events in the chainsync event stream. Useful for
-- monitor which blocks has been seen by the node, regardless whether
-- they are permanent.
ignoreRollbacks :: Monad m => S.Stream (S.Of (ChainSyncEvent a)) m r -> S.Stream (S.Of a) m r
ignoreRollbacks :: Stream (Of (ChainSyncEvent a)) m r -> Stream (Of a) m r
ignoreRollbacks = (ChainSyncEvent a -> Maybe a)
-> Stream (Of (ChainSyncEvent a)) m r -> Stream (Of a) m r
forall (m :: * -> *) a b r.
Monad m =>
(a -> Maybe b) -> Stream (Of a) m r -> Stream (Of b) m r
S.mapMaybe (\case RollForward a
e ChainTip
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
e; ChainSyncEvent a
_ -> Maybe a
forall a. Maybe a
Nothing)