{-# LANGUAGE DuplicateRecordFields #-}

-- | Chain component implementation which uses directly the Node-to-Client
-- protocols to submit "hand-rolled" transactions.
module Hydra.Chain.Direct (
  NetworkMagic (NetworkMagic),
  module Hydra.Chain.Direct,
) where

import Hydra.Prelude

import Cardano.Ledger.Shelley.API qualified as Ledger
import Cardano.Ledger.Slot (EpochInfo)
import Cardano.Slotting.EpochInfo (hoistEpochInfo)
import Control.Concurrent.Class.MonadSTM (
  newEmptyTMVar,
  newTQueueIO,
  putTMVar,
  readTQueue,
  takeTMVar,
  writeTQueue,
 )
import Control.Exception (IOException)
import Control.Monad.Trans.Except (runExcept)
import Hydra.Cardano.Api (
  AnyCardanoEra (..),
  BlockInMode (..),
  CardanoEra (..),
  ChainPoint,
  ChainTip,
  ConsensusModeParams (..),
  EpochSlots (..),
  EraHistory (EraHistory),
  IsShelleyBasedEra (..),
  LocalChainSyncClient (..),
  LocalNodeClientProtocols (..),
  LocalNodeConnectInfo (..),
  NetworkId,
  QueryInShelleyBasedEra (..),
  SocketPath,
  Tx,
  TxInMode (..),
  TxValidationErrorInCardanoMode,
  chainTipToChainPoint,
  connectToLocalNode,
  getTxBody,
  getTxId,
  toLedgerUTxO,
  pattern Block,
 )
import Hydra.Chain (
  ChainComponent,
  ChainStateHistory,
  PostTxError (FailedToPostTx, failureReason),
  currentState,
 )
import Hydra.Chain.CardanoClient (
  QueryException (..),
  QueryPoint (..),
  queryCurrentEraExpr,
  queryEraHistory,
  queryInShelleyBasedEraExpr,
  querySystemStart,
  queryTip,
  queryUTxO,
  runQueryExpr,
 )
import Hydra.Chain.Direct.Handlers (
  ChainSyncHandler,
  DirectChainLog (..),
  chainSyncHandler,
  mkChain,
  newLocalChainState,
  onRollBackward,
  onRollForward,
 )
import Hydra.Chain.Direct.State (
  ChainContext (..),
  ChainStateAt (..),
 )
import Hydra.Chain.Direct.TimeHandle (queryTimeHandle)
import Hydra.Chain.Direct.Util (
  readKeyPair,
 )
import Hydra.Chain.Direct.Wallet (
  TinyWallet (..),
  WalletInfoOnChain (..),
  newTinyWallet,
 )
import Hydra.Chain.ScriptRegistry (queryScriptRegistry)
import Hydra.Logging (Tracer, traceWith)
import Hydra.Options (DirectChainConfig (..))
import Hydra.Tx (Party)
import Ouroboros.Consensus.Cardano.Block (EraMismatch (..))
import Ouroboros.Consensus.HardFork.History qualified as Consensus
import Ouroboros.Network.Magic (NetworkMagic (..))
import Ouroboros.Network.Protocol.ChainSync.Client (
  ChainSyncClient (..),
  ClientStIdle (..),
  ClientStIntersect (..),
  ClientStNext (..),
 )
import Ouroboros.Network.Protocol.LocalTxSubmission.Client (
  LocalTxClientStIdle (..),
  LocalTxSubmissionClient (..),
  SubmitResult (..),
 )
import Text.Printf (printf)

-- | Build the 'ChainContext' from a 'ChainConfig' and additional information.
loadChainContext ::
  DirectChainConfig ->
  -- | Hydra party of our hydra node.
  Party ->
  -- | The current running era we can use to query the node
  IO ChainContext
loadChainContext :: DirectChainConfig -> Party -> IO ChainContext
loadChainContext DirectChainConfig
config Party
party = do
  (VerificationKey PaymentKey
vk, SigningKey PaymentKey
_) <- FilePath -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
readKeyPair FilePath
cardanoSigningKey
  ScriptRegistry
scriptRegistry <- NetworkId -> SocketPath -> TxId -> IO ScriptRegistry
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
NetworkId -> SocketPath -> TxId -> m ScriptRegistry
queryScriptRegistry NetworkId
networkId SocketPath
nodeSocket TxId
hydraScriptsTxId
  ChainContext -> IO ChainContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext -> IO ChainContext)
-> ChainContext -> IO ChainContext
forall a b. (a -> b) -> a -> b
$
    ChainContext
      { NetworkId
networkId :: NetworkId
$sel:networkId:ChainContext :: NetworkId
networkId
      , $sel:ownVerificationKey:ChainContext :: VerificationKey PaymentKey
ownVerificationKey = VerificationKey PaymentKey
vk
      , $sel:ownParty:ChainContext :: Party
ownParty = Party
party
      , ScriptRegistry
scriptRegistry :: ScriptRegistry
$sel:scriptRegistry:ChainContext :: ScriptRegistry
scriptRegistry
      }
 where
  DirectChainConfig
    { NetworkId
networkId :: NetworkId
$sel:networkId:DirectChainConfig :: DirectChainConfig -> NetworkId
networkId
    , SocketPath
nodeSocket :: SocketPath
$sel:nodeSocket:DirectChainConfig :: DirectChainConfig -> SocketPath
nodeSocket
    , TxId
hydraScriptsTxId :: TxId
$sel:hydraScriptsTxId:DirectChainConfig :: DirectChainConfig -> TxId
hydraScriptsTxId
    , FilePath
cardanoSigningKey :: FilePath
$sel:cardanoSigningKey:DirectChainConfig :: DirectChainConfig -> FilePath
cardanoSigningKey
    } = DirectChainConfig
config

mkTinyWallet ::
  Tracer IO DirectChainLog ->
  DirectChainConfig ->
  IO (TinyWallet IO)
mkTinyWallet :: Tracer IO DirectChainLog -> DirectChainConfig -> IO (TinyWallet IO)
mkTinyWallet Tracer IO DirectChainLog
tracer DirectChainConfig
config = do
  (VerificationKey PaymentKey, SigningKey PaymentKey)
keyPair <- FilePath -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
readKeyPair FilePath
cardanoSigningKey
  Tracer IO TinyWalletLog
-> NetworkId
-> (VerificationKey PaymentKey, SigningKey PaymentKey)
-> ChainQuery IO
-> IO (EpochInfo (Either Text))
-> IO (PParams Conway)
-> IO (TinyWallet IO)
newTinyWallet ((TinyWalletLog -> DirectChainLog)
-> Tracer IO DirectChainLog -> Tracer IO TinyWalletLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap TinyWalletLog -> DirectChainLog
Wallet Tracer IO DirectChainLog
tracer) NetworkId
networkId (VerificationKey PaymentKey, SigningKey PaymentKey)
keyPair ChainQuery IO
queryWalletInfo IO (EpochInfo (Either Text))
queryEpochInfo IO (PParams Conway)
querySomePParams
 where
  DirectChainConfig{NetworkId
$sel:networkId:DirectChainConfig :: DirectChainConfig -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectChainConfig :: DirectChainConfig -> SocketPath
nodeSocket :: SocketPath
nodeSocket, FilePath
$sel:cardanoSigningKey:DirectChainConfig :: DirectChainConfig -> FilePath
cardanoSigningKey :: FilePath
cardanoSigningKey} = DirectChainConfig
config

  queryEpochInfo :: IO (EpochInfo (Either Text))
queryEpochInfo = EraHistory -> EpochInfo (Either Text)
toEpochInfo (EraHistory -> EpochInfo (Either Text))
-> IO EraHistory -> IO (EpochInfo (Either Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId -> SocketPath -> QueryPoint -> IO EraHistory
queryEraHistory NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip

  querySomePParams :: IO (PParams Conway)
querySomePParams =
    NetworkId
-> SocketPath
-> QueryPoint
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (PParams Conway)
-> IO (PParams Conway)
forall a.
NetworkId
-> SocketPath
-> QueryPoint
-> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
-> IO a
runQueryExpr NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip (LocalStateQueryExpr
   BlockInMode ChainPoint QueryInMode () IO (PParams Conway)
 -> IO (PParams Conway))
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (PParams Conway)
-> IO (PParams Conway)
forall a b. (a -> b) -> a -> b
$ do
      AnyCardanoEra CardanoEra era
era <- LocalStateQueryExpr
  BlockInMode ChainPoint QueryInMode () IO AnyCardanoEra
forall b p r.
LocalStateQueryExpr b p QueryInMode r IO AnyCardanoEra
queryCurrentEraExpr
      case CardanoEra era
era of
        ConwayEra{} -> ShelleyBasedEra ConwayEra
-> QueryInShelleyBasedEra ConwayEra (PParams Conway)
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (PParams Conway)
forall era a b p r.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era a
-> LocalStateQueryExpr b p QueryInMode r IO a
queryInShelleyBasedEraExpr ShelleyBasedEra ConwayEra
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra QueryInShelleyBasedEra ConwayEra (PParams Conway)
QueryInShelleyBasedEra
  ConwayEra (PParams (ShelleyLedgerEra ConwayEra))
forall era.
QueryInShelleyBasedEra era (PParams (ShelleyLedgerEra era))
QueryProtocolParameters
        CardanoEra era
_ -> IO (PParams Conway)
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (PParams Conway)
forall a.
IO a
-> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PParams Conway)
 -> LocalStateQueryExpr
      BlockInMode ChainPoint QueryInMode () IO (PParams Conway))
-> (QueryException -> IO (PParams Conway))
-> QueryException
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (PParams Conway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryException -> IO (PParams Conway)
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (QueryException
 -> LocalStateQueryExpr
      BlockInMode ChainPoint QueryInMode () IO (PParams Conway))
-> QueryException
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (PParams Conway)
forall a b. (a -> b) -> a -> b
$ EraMismatch -> QueryException
QueryEraMismatchException EraMismatch{ledgerEraName :: Text
ledgerEraName = CardanoEra era -> Text
forall b a. (Show a, IsString b) => a -> b
show CardanoEra era
era, otherEraName :: Text
otherEraName = Text
"Conway"}

  queryWalletInfo :: ChainQuery IO
queryWalletInfo QueryPoint
queryPoint Address ShelleyAddr
address = do
    ChainPoint
point <- case QueryPoint
queryPoint of
      QueryAt ChainPoint
point -> ChainPoint -> IO ChainPoint
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainPoint
point
      QueryPoint
QueryTip -> NetworkId -> SocketPath -> IO ChainPoint
queryTip NetworkId
networkId SocketPath
nodeSocket
    Map (TxIn (EraCrypto Conway)) (TxOut Conway)
walletUTxO <- UTxO Conway -> Map (TxIn (EraCrypto Conway)) (TxOut Conway)
forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
Ledger.unUTxO (UTxO Conway -> Map (TxIn (EraCrypto Conway)) (TxOut Conway))
-> (UTxO -> UTxO Conway)
-> UTxO
-> Map (TxIn (EraCrypto Conway)) (TxOut Conway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> UTxO Conway
UTxO -> UTxO (ShelleyLedgerEra ConwayEra)
toLedgerUTxO (UTxO -> Map (TxIn (EraCrypto Conway)) (TxOut Conway))
-> IO UTxO -> IO (Map (TxIn (EraCrypto Conway)) (TxOut Conway))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId
-> SocketPath -> QueryPoint -> [Address ShelleyAddr] -> IO UTxO
queryUTxO NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip [Address ShelleyAddr
address]
    SystemStart
systemStart <- NetworkId -> SocketPath -> QueryPoint -> IO SystemStart
querySystemStart NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip
    WalletInfoOnChain -> IO WalletInfoOnChain
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalletInfoOnChain -> IO WalletInfoOnChain)
-> WalletInfoOnChain -> IO WalletInfoOnChain
forall a b. (a -> b) -> a -> b
$ WalletInfoOnChain{Map (TxIn (EraCrypto Conway)) (TxOut Conway)
Map TxIn TxOut
walletUTxO :: Map (TxIn (EraCrypto Conway)) (TxOut Conway)
$sel:walletUTxO:WalletInfoOnChain :: Map TxIn TxOut
walletUTxO, SystemStart
systemStart :: SystemStart
$sel:systemStart:WalletInfoOnChain :: SystemStart
systemStart, $sel:tip:WalletInfoOnChain :: ChainPoint
tip = ChainPoint
point}

  toEpochInfo :: EraHistory -> EpochInfo (Either Text)
  toEpochInfo :: EraHistory -> EpochInfo (Either Text)
toEpochInfo (EraHistory Interpreter xs
interpreter) =
    (forall a. Except PastHorizonException a -> Either Text a)
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either Text)
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> EpochInfo m -> EpochInfo n
hoistEpochInfo ((PastHorizonException -> Text)
-> Either PastHorizonException a -> Either Text a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PastHorizonException -> Text
forall b a. (Show a, IsString b) => a -> b
show (Either PastHorizonException a -> Either Text a)
-> (Except PastHorizonException a -> Either PastHorizonException a)
-> Except PastHorizonException a
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except PastHorizonException a -> Either PastHorizonException a
forall e a. Except e a -> Either e a
runExcept) (EpochInfo (Except PastHorizonException)
 -> EpochInfo (Either Text))
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either Text)
forall a b. (a -> b) -> a -> b
$
      Interpreter xs -> EpochInfo (Except PastHorizonException)
forall (xs :: [*]).
Interpreter xs -> EpochInfo (Except PastHorizonException)
Consensus.interpreterToEpochInfo Interpreter xs
interpreter

withDirectChain ::
  Tracer IO DirectChainLog ->
  DirectChainConfig ->
  ChainContext ->
  TinyWallet IO ->
  -- | Chain state loaded from persistence.
  ChainStateHistory Tx ->
  ChainComponent Tx IO a
withDirectChain :: forall a.
Tracer IO DirectChainLog
-> DirectChainConfig
-> ChainContext
-> TinyWallet IO
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
withDirectChain Tracer IO DirectChainLog
tracer DirectChainConfig
config ChainContext
ctx TinyWallet IO
wallet ChainStateHistory Tx
chainStateHistory ChainCallback Tx IO
callback Chain Tx IO -> IO a
action = do
  -- Last known point on chain as loaded from persistence.
  let persistedPoint :: Maybe ChainPoint
persistedPoint = ChainStateAt -> Maybe ChainPoint
recordedAt (ChainStateHistory Tx -> ChainStateType Tx
forall tx. ChainStateHistory tx -> ChainStateType tx
currentState ChainStateHistory Tx
chainStateHistory)
  TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
queue <- IO (TQueue (Tx, TMVar (Maybe (PostTxError Tx))))
IO (TQueue IO (Tx, TMVar (Maybe (PostTxError Tx))))
forall a. IO (TQueue IO a)
forall (m :: * -> *) a. MonadSTM m => m (TQueue m a)
newTQueueIO
  -- Select a chain point from which to start synchronizing
  ChainPoint
chainPoint <- IO ChainPoint
-> (ChainPoint -> IO ChainPoint)
-> Maybe ChainPoint
-> IO ChainPoint
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NetworkId -> SocketPath -> IO ChainPoint
queryTip NetworkId
networkId SocketPath
nodeSocket) ChainPoint -> IO ChainPoint
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ChainPoint -> IO ChainPoint)
-> Maybe ChainPoint -> IO ChainPoint
forall a b. (a -> b) -> a -> b
$ do
    (ChainPoint -> ChainPoint -> ChainPoint
forall a. Ord a => a -> a -> a
max (ChainPoint -> ChainPoint -> ChainPoint)
-> Maybe ChainPoint -> Maybe (ChainPoint -> ChainPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ChainPoint
startChainFrom Maybe (ChainPoint -> ChainPoint)
-> Maybe ChainPoint -> Maybe ChainPoint
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe ChainPoint
persistedPoint)
      Maybe ChainPoint -> Maybe ChainPoint -> Maybe ChainPoint
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ChainPoint
persistedPoint
      Maybe ChainPoint -> Maybe ChainPoint -> Maybe ChainPoint
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ChainPoint
startChainFrom

  let getTimeHandle :: IO TimeHandle
getTimeHandle = NetworkId -> SocketPath -> IO TimeHandle
queryTimeHandle NetworkId
networkId SocketPath
nodeSocket
  LocalChainState IO Tx
localChainState <- ChainStateHistory Tx -> IO (LocalChainState IO Tx)
forall (m :: * -> *) tx.
(MonadSTM m, IsChainState tx) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState ChainStateHistory Tx
chainStateHistory
  let chainHandle :: Chain Tx IO
chainHandle =
        Tracer IO DirectChainLog
-> IO TimeHandle
-> TinyWallet IO
-> ChainContext
-> LocalChainState IO Tx
-> SubmitTx IO
-> Chain Tx IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
Tracer m DirectChainLog
-> GetTimeHandle m
-> TinyWallet m
-> ChainContext
-> LocalChainState m Tx
-> SubmitTx m
-> Chain Tx m
mkChain
          Tracer IO DirectChainLog
tracer
          IO TimeHandle
getTimeHandle
          TinyWallet IO
wallet
          ChainContext
ctx
          LocalChainState IO Tx
localChainState
          (TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx))) -> SubmitTx IO
forall {m :: * -> *} {a} {a}.
(MonadSTM m, MonadThrow m, Exception a) =>
TQueue m (a, TMVar m (Maybe a)) -> a -> m ()
submitTx TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
queue)

  let handler :: ChainSyncHandler IO
handler = Tracer IO DirectChainLog
-> ChainCallback Tx IO
-> IO TimeHandle
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m DirectChainLog
-> ChainCallback Tx m
-> GetTimeHandle m
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler Tracer IO DirectChainLog
tracer ChainCallback Tx IO
callback IO TimeHandle
getTimeHandle ChainContext
ctx LocalChainState IO Tx
localChainState
  Either () a
res <-
    IO () -> IO a -> IO (Either () a)
forall a b. IO a -> IO b -> IO (Either a b)
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> m b -> m (Either a b)
race
      ( (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle IOException -> IO ()
onIOException (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          LocalNodeConnectInfo -> LocalNodeClientProtocolsInMode -> IO ()
forall (m :: * -> *).
MonadIO m =>
LocalNodeConnectInfo -> LocalNodeClientProtocolsInMode -> m ()
connectToLocalNode
            LocalNodeConnectInfo
connectInfo
            (ChainPoint
-> TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
-> ChainSyncHandler IO
-> LocalNodeClientProtocolsInMode
clientProtocols ChainPoint
chainPoint TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
queue ChainSyncHandler IO
handler)
      )
      (Chain Tx IO -> IO a
action Chain Tx IO
chainHandle)
  case Either () a
res of
    Left () -> Text -> IO a
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"'connectTo' cannot terminate but did?"
    Right a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
 where
  DirectChainConfig{NetworkId
$sel:networkId:DirectChainConfig :: DirectChainConfig -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectChainConfig :: DirectChainConfig -> SocketPath
nodeSocket :: SocketPath
nodeSocket, Maybe ChainPoint
startChainFrom :: Maybe ChainPoint
$sel:startChainFrom:DirectChainConfig :: DirectChainConfig -> Maybe ChainPoint
startChainFrom} = DirectChainConfig
config

  connectInfo :: LocalNodeConnectInfo
connectInfo =
    LocalNodeConnectInfo
      { -- REVIEW: This was 432000 before, but all usages in the
        -- cardano-node repository are using this value. This is only
        -- relevant for the Byron era.
        localConsensusModeParams :: ConsensusModeParams
localConsensusModeParams = EpochSlots -> ConsensusModeParams
CardanoModeParams (Word64 -> EpochSlots
EpochSlots Word64
21600)
      , localNodeNetworkId :: NetworkId
localNodeNetworkId = NetworkId
networkId
      , localNodeSocketPath :: SocketPath
localNodeSocketPath = SocketPath
nodeSocket
      }

  clientProtocols :: ChainPoint
-> TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
-> ChainSyncHandler IO
-> LocalNodeClientProtocolsInMode
clientProtocols ChainPoint
point TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
queue ChainSyncHandler IO
handler =
    LocalNodeClientProtocols
      { localChainSyncClient :: LocalChainSyncClient BlockInMode ChainPoint ChainTip IO
localChainSyncClient = ChainSyncClient BlockInMode ChainPoint ChainTip IO ()
-> LocalChainSyncClient BlockInMode ChainPoint ChainTip IO
forall block point tip (m :: * -> *).
ChainSyncClient block point tip m ()
-> LocalChainSyncClient block point tip m
LocalChainSyncClient (ChainSyncClient BlockInMode ChainPoint ChainTip IO ()
 -> LocalChainSyncClient BlockInMode ChainPoint ChainTip IO)
-> ChainSyncClient BlockInMode ChainPoint ChainTip IO ()
-> LocalChainSyncClient BlockInMode ChainPoint ChainTip IO
forall a b. (a -> b) -> a -> b
$ ChainSyncHandler IO
-> TinyWallet IO
-> ChainPoint
-> ChainSyncClient BlockInMode ChainPoint ChainTip IO ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
ChainSyncHandler m
-> TinyWallet m
-> ChainPoint
-> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
chainSyncClient ChainSyncHandler IO
handler TinyWallet IO
wallet ChainPoint
point
      , localTxSubmissionClient :: Maybe
  (LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode IO ())
localTxSubmissionClient = LocalTxSubmissionClient
  TxInMode TxValidationErrorInCardanoMode IO ()
-> Maybe
     (LocalTxSubmissionClient
        TxInMode TxValidationErrorInCardanoMode IO ())
forall a. a -> Maybe a
Just (LocalTxSubmissionClient
   TxInMode TxValidationErrorInCardanoMode IO ()
 -> Maybe
      (LocalTxSubmissionClient
         TxInMode TxValidationErrorInCardanoMode IO ()))
-> LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode IO ()
-> Maybe
     (LocalTxSubmissionClient
        TxInMode TxValidationErrorInCardanoMode IO ())
forall a b. (a -> b) -> a -> b
$ Tracer IO DirectChainLog
-> TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
-> LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode IO ()
forall (m :: * -> *).
(MonadSTM m, MonadDelay m) =>
Tracer m DirectChainLog
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode m ()
txSubmissionClient Tracer IO DirectChainLog
tracer TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
queue
      , localStateQueryClient :: Maybe
  (LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ())
localStateQueryClient = Maybe
  (LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ())
forall a. Maybe a
Nothing
      , localTxMonitoringClient :: Maybe (LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO ())
localTxMonitoringClient = Maybe (LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO ())
forall a. Maybe a
Nothing
      }

  submitTx :: TQueue m (a, TMVar m (Maybe a)) -> a -> m ()
submitTx TQueue m (a, TMVar m (Maybe a))
queue a
tx = do
    TMVar m (Maybe a)
response <- STM m (TMVar m (Maybe a)) -> m (TMVar m (Maybe a))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (TMVar m (Maybe a)) -> m (TMVar m (Maybe a)))
-> STM m (TMVar m (Maybe a)) -> m (TMVar m (Maybe a))
forall a b. (a -> b) -> a -> b
$ do
      TMVar m (Maybe a)
response <- STM m (TMVar m (Maybe a))
forall a. STM m (TMVar m a)
forall (m :: * -> *) a. MonadSTM m => STM m (TMVar m a)
newEmptyTMVar
      TQueue m (a, TMVar m (Maybe a))
-> (a, TMVar m (Maybe a)) -> STM m ()
forall a. TQueue m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue m (a, TMVar m (Maybe a))
queue (a
tx, TMVar m (Maybe a)
response)
      TMVar m (Maybe a) -> STM m (TMVar m (Maybe a))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return TMVar m (Maybe a)
response
    STM m (Maybe a) -> m (Maybe a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TMVar m (Maybe a) -> STM m (Maybe a)
forall a. TMVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
takeTMVar TMVar m (Maybe a)
response)
      m (Maybe a) -> (Maybe a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) a -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO

  onIOException :: IOException -> IO ()
  onIOException :: IOException -> IO ()
onIOException IOException
ioException =
    ConnectException -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ConnectException -> IO ()) -> ConnectException -> IO ()
forall a b. (a -> b) -> a -> b
$
      ConnectException
        { IOException
ioException :: IOException
$sel:ioException:ConnectException :: IOException
ioException
        , SocketPath
nodeSocket :: SocketPath
$sel:nodeSocket:ConnectException :: SocketPath
nodeSocket
        , NetworkId
networkId :: NetworkId
$sel:networkId:ConnectException :: NetworkId
networkId
        }

data ConnectException = ConnectException
  { ConnectException -> IOException
ioException :: IOException
  , ConnectException -> SocketPath
nodeSocket :: SocketPath
  , ConnectException -> NetworkId
networkId :: NetworkId
  }
  deriving stock (Int -> ConnectException -> ShowS
[ConnectException] -> ShowS
ConnectException -> FilePath
(Int -> ConnectException -> ShowS)
-> (ConnectException -> FilePath)
-> ([ConnectException] -> ShowS)
-> Show ConnectException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConnectException -> ShowS
showsPrec :: Int -> ConnectException -> ShowS
$cshow :: ConnectException -> FilePath
show :: ConnectException -> FilePath
$cshowList :: [ConnectException] -> ShowS
showList :: [ConnectException] -> ShowS
Show)

instance Exception ConnectException

-- | Thrown when the user-provided custom point of intersection is unknown to
-- the local node. This may happen if users shut down their node quickly after
-- starting them and hold on a not-so-stable point of the chain. When they turn
-- the node back on, that point may no longer exist on the network if a fork
-- with deeper roots has been adopted in the meantime.
newtype IntersectionNotFoundException = IntersectionNotFound
  { IntersectionNotFoundException -> ChainPoint
requestedPoint :: ChainPoint
  }
  deriving newtype (Int -> IntersectionNotFoundException -> ShowS
[IntersectionNotFoundException] -> ShowS
IntersectionNotFoundException -> FilePath
(Int -> IntersectionNotFoundException -> ShowS)
-> (IntersectionNotFoundException -> FilePath)
-> ([IntersectionNotFoundException] -> ShowS)
-> Show IntersectionNotFoundException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IntersectionNotFoundException -> ShowS
showsPrec :: Int -> IntersectionNotFoundException -> ShowS
$cshow :: IntersectionNotFoundException -> FilePath
show :: IntersectionNotFoundException -> FilePath
$cshowList :: [IntersectionNotFoundException] -> ShowS
showList :: [IntersectionNotFoundException] -> ShowS
Show)

instance Exception IntersectionNotFoundException

data EraNotSupportedException
  = EraNotSupportedAnymore {EraNotSupportedException -> Text
otherEraName :: Text}
  | EraNotSupportedYet {otherEraName :: Text}
  deriving stock (Int -> EraNotSupportedException -> ShowS
[EraNotSupportedException] -> ShowS
EraNotSupportedException -> FilePath
(Int -> EraNotSupportedException -> ShowS)
-> (EraNotSupportedException -> FilePath)
-> ([EraNotSupportedException] -> ShowS)
-> Show EraNotSupportedException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EraNotSupportedException -> ShowS
showsPrec :: Int -> EraNotSupportedException -> ShowS
$cshow :: EraNotSupportedException -> FilePath
show :: EraNotSupportedException -> FilePath
$cshowList :: [EraNotSupportedException] -> ShowS
showList :: [EraNotSupportedException] -> ShowS
Show)

instance Exception EraNotSupportedException where
  displayException :: EraNotSupportedException -> FilePath
displayException = \case
    EraNotSupportedAnymore{Text
$sel:otherEraName:EraNotSupportedAnymore :: EraNotSupportedException -> Text
otherEraName :: Text
otherEraName} ->
      FilePath -> Text -> FilePath
forall r. PrintfType r => FilePath -> r
printf
        FilePath
"Received blocks of not anymore supported era (%s). \
        \Please wait for your cardano-node to be fully synchronized."
        Text
otherEraName
    EraNotSupportedYet{Text
$sel:otherEraName:EraNotSupportedAnymore :: EraNotSupportedException -> Text
otherEraName :: Text
otherEraName} ->
      FilePath -> Text -> FilePath
forall r. PrintfType r => FilePath -> r
printf
        FilePath
"Received blocks of not yet supported era (%s). \
        \Please upgrade your hydra-node."
        Text
otherEraName

-- | The block type used in the node-to-client protocols.
type BlockType = BlockInMode

chainSyncClient ::
  forall m.
  (MonadSTM m, MonadThrow m) =>
  ChainSyncHandler m ->
  TinyWallet m ->
  ChainPoint ->
  ChainSyncClient BlockType ChainPoint ChainTip m ()
chainSyncClient :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
ChainSyncHandler m
-> TinyWallet m
-> ChainPoint
-> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
chainSyncClient ChainSyncHandler m
handler TinyWallet m
wallet ChainPoint
startingPoint =
  m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
-> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
 -> ChainSyncClient BlockInMode ChainPoint ChainTip m ())
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
-> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
forall a b. (a -> b) -> a -> b
$
    ClientStIdle BlockInMode ChainPoint ChainTip m ()
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStIdle BlockInMode ChainPoint ChainTip m ()
 -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ()))
-> ClientStIdle BlockInMode ChainPoint ChainTip m ()
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall a b. (a -> b) -> a -> b
$
      [ChainPoint]
-> ClientStIntersect BlockInMode ChainPoint ChainTip m ()
-> ClientStIdle BlockInMode ChainPoint ChainTip m ()
forall point header tip (m :: * -> *) a.
[point]
-> ClientStIntersect header point tip m a
-> ClientStIdle header point tip m a
SendMsgFindIntersect
        [ChainPoint
startingPoint]
        ( (ChainPoint
 -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ()))
-> ClientStIntersect BlockInMode ChainPoint ChainTip m ()
clientStIntersect
            (\ChainPoint
_ -> IntersectionNotFoundException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ChainPoint -> IntersectionNotFoundException
IntersectionNotFound ChainPoint
startingPoint))
        )
 where
  clientStIntersect ::
    (ChainPoint -> m (ClientStIdle BlockType ChainPoint ChainTip m ())) ->
    ClientStIntersect BlockType ChainPoint ChainTip m ()
  clientStIntersect :: (ChainPoint
 -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ()))
-> ClientStIntersect BlockInMode ChainPoint ChainTip m ()
clientStIntersect ChainPoint -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
onIntersectionNotFound =
    ClientStIntersect
      { recvMsgIntersectFound :: ChainPoint
-> ChainTip -> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
recvMsgIntersectFound = \ChainPoint
_ ChainTip
_ ->
          m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
-> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (ClientStIdle BlockInMode ChainPoint ChainTip m ()
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle BlockInMode ChainPoint ChainTip m ()
clientStIdle)
      , recvMsgIntersectNotFound :: ChainTip -> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
recvMsgIntersectNotFound =
          m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
-> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
 -> ChainSyncClient BlockInMode ChainPoint ChainTip m ())
-> (ChainTip
    -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ()))
-> ChainTip
-> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainPoint -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
onIntersectionNotFound (ChainPoint
 -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ()))
-> (ChainTip -> ChainPoint)
-> ChainTip
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainTip -> ChainPoint
chainTipToChainPoint
      }

  clientStIdle :: ClientStIdle BlockType ChainPoint ChainTip m ()
  clientStIdle :: ClientStIdle BlockInMode ChainPoint ChainTip m ()
clientStIdle = m ()
-> ClientStNext BlockInMode ChainPoint ChainTip m ()
-> ClientStIdle BlockInMode ChainPoint ChainTip m ()
forall (m :: * -> *) header point tip a.
m ()
-> ClientStNext header point tip m a
-> ClientStIdle header point tip m a
SendMsgRequestNext (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ClientStNext BlockInMode ChainPoint ChainTip m ()
clientStNext

  clientStNext :: ClientStNext BlockType ChainPoint ChainTip m ()
  clientStNext :: ClientStNext BlockInMode ChainPoint ChainTip m ()
clientStNext =
    ClientStNext
      { recvMsgRollForward :: BlockInMode
-> ChainTip -> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
recvMsgRollForward = \BlockInMode
blockInMode ChainTip
_tip -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
-> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
 -> ChainSyncClient BlockInMode ChainPoint ChainTip m ())
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
-> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
forall a b. (a -> b) -> a -> b
$ do
          case BlockInMode
blockInMode of
            BlockInMode CardanoEra era
ConwayEra (Block BlockHeader
header [Tx era]
txs) -> do
              -- Update the tiny wallet
              TinyWallet m -> BlockHeader -> [Tx] -> m ()
forall (m :: * -> *). TinyWallet m -> BlockHeader -> [Tx] -> m ()
update TinyWallet m
wallet BlockHeader
header [Tx era]
[Tx]
txs
              -- Observe Hydra transactions
              ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward ChainSyncHandler m
handler BlockHeader
header [Tx era]
[Tx]
txs
              ClientStIdle BlockInMode ChainPoint ChainTip m ()
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle BlockInMode ChainPoint ChainTip m ()
clientStIdle
            BlockInMode era :: CardanoEra era
era@CardanoEra era
BabbageEra Block era
_ -> EraNotSupportedException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (EraNotSupportedException
 -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall a b. (a -> b) -> a -> b
$ EraNotSupportedAnymore{$sel:otherEraName:EraNotSupportedAnymore :: Text
otherEraName = CardanoEra era -> Text
forall b a. (Show a, IsString b) => a -> b
show CardanoEra era
era}
            BlockInMode era :: CardanoEra era
era@CardanoEra era
AlonzoEra Block era
_ -> EraNotSupportedException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (EraNotSupportedException
 -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall a b. (a -> b) -> a -> b
$ EraNotSupportedAnymore{$sel:otherEraName:EraNotSupportedAnymore :: Text
otherEraName = CardanoEra era -> Text
forall b a. (Show a, IsString b) => a -> b
show CardanoEra era
era}
            BlockInMode era :: CardanoEra era
era@CardanoEra era
AllegraEra Block era
_ -> EraNotSupportedException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (EraNotSupportedException
 -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall a b. (a -> b) -> a -> b
$ EraNotSupportedAnymore{$sel:otherEraName:EraNotSupportedAnymore :: Text
otherEraName = CardanoEra era -> Text
forall b a. (Show a, IsString b) => a -> b
show CardanoEra era
era}
            BlockInMode era :: CardanoEra era
era@CardanoEra era
MaryEra Block era
_ -> EraNotSupportedException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (EraNotSupportedException
 -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall a b. (a -> b) -> a -> b
$ EraNotSupportedAnymore{$sel:otherEraName:EraNotSupportedAnymore :: Text
otherEraName = CardanoEra era -> Text
forall b a. (Show a, IsString b) => a -> b
show CardanoEra era
era}
            BlockInMode era :: CardanoEra era
era@CardanoEra era
ShelleyEra Block era
_ -> EraNotSupportedException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (EraNotSupportedException
 -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall a b. (a -> b) -> a -> b
$ EraNotSupportedAnymore{$sel:otherEraName:EraNotSupportedAnymore :: Text
otherEraName = CardanoEra era -> Text
forall b a. (Show a, IsString b) => a -> b
show CardanoEra era
era}
            BlockInMode era :: CardanoEra era
era@CardanoEra era
ByronEra Block era
_ -> EraNotSupportedException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (EraNotSupportedException
 -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall a b. (a -> b) -> a -> b
$ EraNotSupportedAnymore{$sel:otherEraName:EraNotSupportedAnymore :: Text
otherEraName = CardanoEra era -> Text
forall b a. (Show a, IsString b) => a -> b
show CardanoEra era
era}
      , recvMsgRollBackward :: ChainPoint
-> ChainTip -> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
recvMsgRollBackward = \ChainPoint
point ChainTip
_tip -> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
-> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
 -> ChainSyncClient BlockInMode ChainPoint ChainTip m ())
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
-> ChainSyncClient BlockInMode ChainPoint ChainTip m ()
forall a b. (a -> b) -> a -> b
$ do
          -- Re-initialize the tiny wallet
          TinyWallet m -> m ()
forall (m :: * -> *). TinyWallet m -> m ()
reset TinyWallet m
wallet
          -- Rollback main chain sync handler
          ChainSyncHandler m -> ChainPoint -> m ()
forall (m :: * -> *). ChainSyncHandler m -> ChainPoint -> m ()
onRollBackward ChainSyncHandler m
handler ChainPoint
point
          ClientStIdle BlockInMode ChainPoint ChainTip m ()
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle BlockInMode ChainPoint ChainTip m ()
clientStIdle
      }

txSubmissionClient ::
  forall m.
  (MonadSTM m, MonadDelay m) =>
  Tracer m DirectChainLog ->
  TQueue m (Tx, TMVar m (Maybe (PostTxError Tx))) ->
  LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode m ()
txSubmissionClient :: forall (m :: * -> *).
(MonadSTM m, MonadDelay m) =>
Tracer m DirectChainLog
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode m ()
txSubmissionClient Tracer m DirectChainLog
tracer TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
queue =
  m (LocalTxClientStIdle
     TxInMode TxValidationErrorInCardanoMode m ())
-> LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode m ()
forall tx reject (m :: * -> *) a.
m (LocalTxClientStIdle tx reject m a)
-> LocalTxSubmissionClient tx reject m a
LocalTxSubmissionClient m (LocalTxClientStIdle
     TxInMode TxValidationErrorInCardanoMode m ())
clientStIdle
 where
  clientStIdle :: m (LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode m ())
  clientStIdle :: m (LocalTxClientStIdle
     TxInMode TxValidationErrorInCardanoMode m ())
clientStIdle = do
    (Tx
tx, TMVar m (Maybe (PostTxError Tx))
response) <- STM m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> m (Tx, TMVar m (Maybe (PostTxError Tx)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Tx, TMVar m (Maybe (PostTxError Tx)))
 -> m (Tx, TMVar m (Maybe (PostTxError Tx))))
-> STM m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> m (Tx, TMVar m (Maybe (PostTxError Tx)))
forall a b. (a -> b) -> a -> b
$ TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> STM m (Tx, TMVar m (Maybe (PostTxError Tx)))
forall a. TQueue m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
queue
    let txId :: TxId
txId = TxBody ConwayEra -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody ConwayEra -> TxId) -> TxBody ConwayEra -> TxId
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody ConwayEra
forall era. Tx era -> TxBody era
getTxBody Tx
tx
    Tracer m DirectChainLog -> DirectChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DirectChainLog
tracer PostingTx{TxId
txId :: TxId
$sel:txId:ToPost :: TxId
txId}
    LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode m ()
-> m (LocalTxClientStIdle
        TxInMode TxValidationErrorInCardanoMode m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode m ()
 -> m (LocalTxClientStIdle
         TxInMode TxValidationErrorInCardanoMode m ()))
-> LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode m ()
-> m (LocalTxClientStIdle
        TxInMode TxValidationErrorInCardanoMode m ())
forall a b. (a -> b) -> a -> b
$
      TxInMode
-> (SubmitResult TxValidationErrorInCardanoMode
    -> m (LocalTxClientStIdle
            TxInMode TxValidationErrorInCardanoMode m ()))
-> LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode m ()
forall tx reject (m :: * -> *) a.
tx
-> (SubmitResult reject -> m (LocalTxClientStIdle tx reject m a))
-> LocalTxClientStIdle tx reject m a
SendMsgSubmitTx
        (ShelleyBasedEra ConwayEra -> Tx -> TxInMode
forall era. ShelleyBasedEra era -> Tx era -> TxInMode
TxInMode ShelleyBasedEra ConwayEra
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra Tx
tx)
        ( \case
            SubmitResult TxValidationErrorInCardanoMode
SubmitSuccess -> do
              Tracer m DirectChainLog -> DirectChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DirectChainLog
tracer PostedTx{TxId
txId :: TxId
$sel:txId:ToPost :: TxId
txId}
              STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TMVar m (Maybe (PostTxError Tx))
-> Maybe (PostTxError Tx) -> STM m ()
forall a. TMVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m ()
putTMVar TMVar m (Maybe (PostTxError Tx))
response Maybe (PostTxError Tx)
forall a. Maybe a
Nothing)
              m (LocalTxClientStIdle
     TxInMode TxValidationErrorInCardanoMode m ())
clientStIdle
            SubmitFail TxValidationErrorInCardanoMode
err -> do
              -- XXX: Very complicated / opaque show instance and no unpacking
              -- possible because of missing data constructors from cardano-api
              let postTxError :: PostTxError Tx
postTxError = FailedToPostTx{$sel:failureReason:NoSeedInput :: Text
failureReason = TxValidationErrorInCardanoMode -> Text
forall b a. (Show a, IsString b) => a -> b
show TxValidationErrorInCardanoMode
err}
              Tracer m DirectChainLog -> DirectChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DirectChainLog
tracer PostingFailed{Tx
tx :: Tx
$sel:tx:ToPost :: Tx
tx, PostTxError Tx
postTxError :: PostTxError Tx
$sel:postTxError:ToPost :: PostTxError Tx
postTxError}
              -- NOTE: Delay callback in case our transaction got invalidated
              -- because of a transaction seen in a block. This gives the
              -- observing side of the chain layer time to process the
              -- transaction and business logic might even ignore this error.
              DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
              STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TMVar m (Maybe (PostTxError Tx))
-> Maybe (PostTxError Tx) -> STM m ()
forall a. TMVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m ()
putTMVar TMVar m (Maybe (PostTxError Tx))
response (PostTxError Tx -> Maybe (PostTxError Tx)
forall a. a -> Maybe a
Just PostTxError Tx
postTxError))
              m (LocalTxClientStIdle
     TxInMode TxValidationErrorInCardanoMode m ())
clientStIdle
        )