{-# 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.Api.Consensus (EraMismatch (..))
import Control.Concurrent.Class.MonadSTM (
  newEmptyTMVar,
  newTQueueIO,
  putTMVar,
  readTQueue,
  takeTMVar,
  writeTQueue,
 )
import Control.Exception (IOException)
import Hydra.Cardano.Api (
  AnyCardanoEra (..),
  BlockInMode (..),
  CardanoEra (..),
  ChainPoint (..),
  ChainTip,
  ConsensusModeParams (..),
  EpochSlots (..),
  IsShelleyBasedEra (..),
  LocalChainSyncClient (..),
  LocalNodeClientProtocols (..),
  LocalNodeConnectInfo (..),
  NetworkId,
  QueryInShelleyBasedEra (..),
  SocketPath,
  Tx,
  TxInMode (..),
  TxValidationErrorInCardanoMode,
  chainTipToChainPoint,
  connectToLocalNode,
  getBlockHeader,
  getBlockTxs,
  getTxBody,
  getTxId,
 )
import Hydra.Chain (
  ChainComponent,
  ChainStateHistory,
  PostTxError (..),
  currentState,
 )
import Hydra.Chain.Backend (ChainBackend (..))
import Hydra.Chain.CardanoClient qualified as CardanoClient
import Hydra.Chain.Direct.Handlers (
  CardanoChainLog (..),
  ChainSyncHandler,
  chainSyncHandler,
  mkChain,
  newLocalChainState,
  onRollBackward,
  onRollForward,
 )
import Hydra.Chain.Direct.State (
  ChainContext (..),
  ChainStateAt (..),
 )
import Hydra.Chain.Direct.TimeHandle (queryTimeHandle)
import Hydra.Chain.Direct.Wallet (
  TinyWallet (..),
 )
import Hydra.Chain.ScriptRegistry qualified as ScriptRegistry
import Hydra.Logging (Tracer, traceWith)
import Hydra.Options (CardanoChainConfig (..), DirectOptions (..))
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)

newtype DirectBackend = DirectBackend {DirectBackend -> DirectOptions
options :: DirectOptions}

instance ChainBackend DirectBackend where
  queryGenesisParameters :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> m (GenesisParameters ShelleyEra)
queryGenesisParameters (DirectBackend DirectOptions{NetworkId
networkId :: NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId, SocketPath
nodeSocket :: SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket}) =
    IO (GenesisParameters ShelleyEra)
-> m (GenesisParameters ShelleyEra)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (GenesisParameters ShelleyEra)
 -> m (GenesisParameters ShelleyEra))
-> IO (GenesisParameters ShelleyEra)
-> m (GenesisParameters ShelleyEra)
forall a b. (a -> b) -> a -> b
$ NetworkId
-> SocketPath -> QueryPoint -> IO (GenesisParameters ShelleyEra)
CardanoClient.queryGenesisParameters NetworkId
networkId SocketPath
nodeSocket QueryPoint
CardanoClient.QueryTip

  queryScriptRegistry :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> [TxId] -> m ScriptRegistry
queryScriptRegistry (DirectBackend DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket}) =
    NetworkId -> SocketPath -> [TxId] -> m ScriptRegistry
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
NetworkId -> SocketPath -> [TxId] -> m ScriptRegistry
ScriptRegistry.queryScriptRegistry NetworkId
networkId SocketPath
nodeSocket

  queryNetworkId :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> m NetworkId
queryNetworkId (DirectBackend DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId}) = NetworkId -> m NetworkId
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NetworkId
networkId

  queryTip :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> m ChainPoint
queryTip (DirectBackend DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket}) =
    IO ChainPoint -> m ChainPoint
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ChainPoint -> m ChainPoint) -> IO ChainPoint -> m ChainPoint
forall a b. (a -> b) -> a -> b
$ NetworkId -> SocketPath -> IO ChainPoint
CardanoClient.queryTip NetworkId
networkId SocketPath
nodeSocket

  queryUTxO :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> [Address ShelleyAddr] -> m UTxO
queryUTxO (DirectBackend DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket}) [Address ShelleyAddr]
addresses =
    IO UTxO -> m UTxO
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTxO -> m UTxO) -> IO UTxO -> m UTxO
forall a b. (a -> b) -> a -> b
$ NetworkId
-> SocketPath -> QueryPoint -> [Address ShelleyAddr] -> IO UTxO
CardanoClient.queryUTxO NetworkId
networkId SocketPath
nodeSocket QueryPoint
CardanoClient.QueryTip [Address ShelleyAddr]
addresses

  queryEraHistory :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> QueryPoint -> m EraHistory
queryEraHistory (DirectBackend DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket}) QueryPoint
queryPoint =
    IO EraHistory -> m EraHistory
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EraHistory -> m EraHistory) -> IO EraHistory -> m EraHistory
forall a b. (a -> b) -> a -> b
$ NetworkId -> SocketPath -> QueryPoint -> IO EraHistory
CardanoClient.queryEraHistory NetworkId
networkId SocketPath
nodeSocket QueryPoint
queryPoint

  querySystemStart :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> QueryPoint -> m SystemStart
querySystemStart (DirectBackend DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket}) QueryPoint
queryPoint =
    IO SystemStart -> m SystemStart
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SystemStart -> m SystemStart)
-> IO SystemStart -> m SystemStart
forall a b. (a -> b) -> a -> b
$ NetworkId -> SocketPath -> QueryPoint -> IO SystemStart
CardanoClient.querySystemStart NetworkId
networkId SocketPath
nodeSocket QueryPoint
queryPoint

  queryProtocolParameters :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> QueryPoint -> m (PParams LedgerEra)
queryProtocolParameters (DirectBackend DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket}) QueryPoint
queryPoint =
    IO (PParams LedgerEra) -> m (PParams LedgerEra)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PParams LedgerEra) -> m (PParams LedgerEra))
-> IO (PParams LedgerEra) -> m (PParams LedgerEra)
forall a b. (a -> b) -> a -> b
$ NetworkId
-> SocketPath
-> QueryPoint
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (PParams LedgerEra)
-> IO (PParams LedgerEra)
forall a.
NetworkId
-> SocketPath
-> QueryPoint
-> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
-> IO a
CardanoClient.runQueryExpr NetworkId
networkId SocketPath
nodeSocket QueryPoint
queryPoint (LocalStateQueryExpr
   BlockInMode ChainPoint QueryInMode () IO (PParams LedgerEra)
 -> IO (PParams LedgerEra))
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (PParams LedgerEra)
-> IO (PParams LedgerEra)
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
CardanoClient.queryCurrentEraExpr
      case CardanoEra era
era of
        ConwayEra{} -> ShelleyBasedEra ConwayEra
-> QueryInShelleyBasedEra ConwayEra (PParams ConwayEra)
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (PParams ConwayEra)
forall era a b p r.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era a
-> LocalStateQueryExpr b p QueryInMode r IO a
CardanoClient.queryInShelleyBasedEraExpr ShelleyBasedEra ConwayEra
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra QueryInShelleyBasedEra ConwayEra (PParams ConwayEra)
QueryInShelleyBasedEra ConwayEra (PParams LedgerEra)
forall era.
QueryInShelleyBasedEra era (PParams (ShelleyLedgerEra era))
QueryProtocolParameters
        CardanoEra era
_ -> IO (PParams ConwayEra)
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (PParams ConwayEra)
forall a.
IO a
-> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PParams ConwayEra)
 -> LocalStateQueryExpr
      BlockInMode ChainPoint QueryInMode () IO (PParams ConwayEra))
-> (QueryException -> IO (PParams ConwayEra))
-> QueryException
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (PParams ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryException -> IO (PParams ConwayEra)
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 ConwayEra))
-> QueryException
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (PParams ConwayEra)
forall a b. (a -> b) -> a -> b
$ EraMismatch -> QueryException
CardanoClient.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"}
  queryStakePools :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> QueryPoint -> m (Set PoolId)
queryStakePools (DirectBackend DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket}) QueryPoint
queryPoint =
    IO (Set PoolId) -> m (Set PoolId)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Set PoolId) -> m (Set PoolId))
-> IO (Set PoolId) -> m (Set PoolId)
forall a b. (a -> b) -> a -> b
$ NetworkId -> SocketPath -> QueryPoint -> IO (Set PoolId)
CardanoClient.queryStakePools NetworkId
networkId SocketPath
nodeSocket QueryPoint
queryPoint

  queryUTxOFor :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> QueryPoint -> VerificationKey PaymentKey -> m UTxO
queryUTxOFor (DirectBackend DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket}) QueryPoint
queryPoint VerificationKey PaymentKey
vk =
    IO UTxO -> m UTxO
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTxO -> m UTxO) -> IO UTxO -> m UTxO
forall a b. (a -> b) -> a -> b
$ NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO UTxO
CardanoClient.queryUTxOFor NetworkId
networkId SocketPath
nodeSocket QueryPoint
queryPoint VerificationKey PaymentKey
vk

  submitTransaction :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> Tx -> m ()
submitTransaction (DirectBackend DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket}) Tx
tx =
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ NetworkId -> SocketPath -> Tx -> IO ()
CardanoClient.submitTransaction NetworkId
networkId SocketPath
nodeSocket Tx
tx

  awaitTransaction :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> Tx -> m UTxO
awaitTransaction (DirectBackend DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket}) Tx
tx =
    IO UTxO -> m UTxO
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTxO -> m UTxO) -> IO UTxO -> m UTxO
forall a b. (a -> b) -> a -> b
$ NetworkId -> SocketPath -> Tx -> IO UTxO
CardanoClient.awaitTransaction NetworkId
networkId SocketPath
nodeSocket Tx
tx

withDirectChain ::
  DirectBackend ->
  Tracer IO CardanoChainLog ->
  CardanoChainConfig ->
  ChainContext ->
  TinyWallet IO ->
  -- | Chain state loaded from persistence.
  ChainStateHistory Tx ->
  ChainComponent Tx IO a
withDirectChain :: forall a.
DirectBackend
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> ChainContext
-> TinyWallet IO
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
withDirectChain DirectBackend
backend Tracer IO CardanoChainLog
tracer CardanoChainConfig
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 (DirectBackend -> IO ChainPoint
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> m ChainPoint
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
DirectBackend -> m ChainPoint
queryTip DirectBackend
backend) 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 = DirectBackend -> IO TimeHandle
forall backend. ChainBackend backend => backend -> IO TimeHandle
queryTimeHandle DirectBackend
backend
  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 CardanoChainLog
-> IO TimeHandle
-> TinyWallet IO
-> ChainContext
-> LocalChainState IO Tx
-> (Tx -> IO ())
-> Chain Tx IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
Tracer m CardanoChainLog
-> GetTimeHandle m
-> TinyWallet m
-> ChainContext
-> LocalChainState m Tx
-> SubmitTx m
-> Chain Tx m
mkChain
          Tracer IO CardanoChainLog
tracer
          IO TimeHandle
getTimeHandle
          TinyWallet IO
wallet
          ChainContext
ctx
          LocalChainState IO Tx
localChainState
          (TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx))) -> Tx -> 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 CardanoChainLog
-> ChainCallback Tx IO
-> IO TimeHandle
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m CardanoChainLog
-> ChainCallback Tx m
-> GetTimeHandle m
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler Tracer IO CardanoChainLog
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
            (NetworkId -> SocketPath -> LocalNodeConnectInfo
connectInfo NetworkId
networkId SocketPath
nodeSocket)
            (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
  DirectBackend{$sel:options:DirectBackend :: DirectBackend -> DirectOptions
options = DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket}} = DirectBackend
backend
  CardanoChainConfig{Maybe ChainPoint
startChainFrom :: Maybe ChainPoint
$sel:startChainFrom:CardanoChainConfig :: CardanoChainConfig -> Maybe ChainPoint
startChainFrom} = CardanoChainConfig
config

  connectInfo :: NetworkId -> SocketPath -> LocalNodeConnectInfo
connectInfo NetworkId
networkId' SocketPath
nodeSocket' =
    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 CardanoChainLog
-> TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
-> LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode IO ()
forall (m :: * -> *).
(MonadSTM m, MonadDelay m) =>
Tracer m CardanoChainLog
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode m ()
txSubmissionClient Tracer IO CardanoChainLog
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 =
    DirectConnectException -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (DirectConnectException -> IO ())
-> DirectConnectException -> IO ()
forall a b. (a -> b) -> a -> b
$
      DirectConnectException
        { IOException
ioException :: IOException
$sel:ioException:DirectConnectException :: IOException
ioException
        , SocketPath
nodeSocket :: SocketPath
$sel:nodeSocket:DirectConnectException :: SocketPath
nodeSocket
        , NetworkId
networkId :: NetworkId
$sel:networkId:DirectConnectException :: NetworkId
networkId
        }

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

instance Exception DirectConnectException

-- | 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 -> String
(Int -> IntersectionNotFoundException -> ShowS)
-> (IntersectionNotFoundException -> String)
-> ([IntersectionNotFoundException] -> ShowS)
-> Show IntersectionNotFoundException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IntersectionNotFoundException -> ShowS
showsPrec :: Int -> IntersectionNotFoundException -> ShowS
$cshow :: IntersectionNotFoundException -> String
show :: IntersectionNotFoundException -> String
$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 -> String
(Int -> EraNotSupportedException -> ShowS)
-> (EraNotSupportedException -> String)
-> ([EraNotSupportedException] -> ShowS)
-> Show EraNotSupportedException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EraNotSupportedException -> ShowS
showsPrec :: Int -> EraNotSupportedException -> ShowS
$cshow :: EraNotSupportedException -> String
show :: EraNotSupportedException -> String
$cshowList :: [EraNotSupportedException] -> ShowS
showList :: [EraNotSupportedException] -> ShowS
Show)

instance Exception EraNotSupportedException where
  displayException :: EraNotSupportedException -> String
displayException = \case
    EraNotSupportedAnymore{Text
$sel:otherEraName:EraNotSupportedAnymore :: EraNotSupportedException -> Text
otherEraName :: Text
otherEraName} ->
      String -> Text -> String
forall r. PrintfType r => String -> r
printf
        String
"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} ->
      String -> Text -> String
forall r. PrintfType r => String -> r
printf
        String
"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 era
block -> do
              let header :: BlockHeader
header = Block era -> BlockHeader
forall era. Block era -> BlockHeader
getBlockHeader Block era
block
              let txs :: [Tx era]
txs = Block era -> [Tx era]
forall era. Block era -> [Tx era]
getBlockTxs Block era
block
              -- 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 CardanoChainLog ->
  TQueue m (Tx, TMVar m (Maybe (PostTxError Tx))) ->
  LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode m ()
txSubmissionClient :: forall (m :: * -> *).
(MonadSTM m, MonadDelay m) =>
Tracer m CardanoChainLog
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode m ()
txSubmissionClient Tracer m CardanoChainLog
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 CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
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 CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
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, $sel:failingTx:NoSeedInput :: Tx
failingTx = Tx
tx}
              Tracer m CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
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
        )