{-# 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 Control.Concurrent.Class.MonadSTM (
  putTMVar,
  readTQueue,
  takeTMVar,
  writeTQueue,
 )
import Control.Exception (IOException)
import Data.Text qualified as T
import Hydra.Cardano.Api (
  BlockInMode (..),
  CardanoEra (..),
  ChainPoint (..),
  ChainTip,
  ConsensusModeParams (..),
  EpochSlots (..),
  LocalChainSyncClient (..),
  LocalNodeClientProtocols (..),
  LocalNodeConnectInfo (..),
  NetworkId,
  SocketPath,
  Tx,
  TxInMode (..),
  TxValidationErrorInCardanoMode,
  chainTipToChainPoint,
  connectToLocalNode,
  getBlockHeader,
  getBlockTxs,
  getTxBody,
  getTxId,
  shelleyBasedEra,
 )
import Hydra.Chain (
  ChainComponent,
  ChainStateHistory (..),
  PostTxError (..),
  prefixOf,
 )
import Hydra.Chain.Backend (ChainBackend (..))
import Hydra.Chain.CardanoClient qualified as CardanoClient
import Hydra.Chain.Direct.Handlers (
  CardanoChainLog (..),
  ChainSyncHandler,
  StartingDecision (..),
  chainSyncHandler,
  mkChain,
  newLocalChainState,
  onRollBackward,
  onRollForward,
 )
import Hydra.Chain.Direct.State (ChainContext (..))
import Hydra.Chain.Direct.TimeHandle (newCachedTimeHandle, 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 a = DirectBackend (ReaderT DirectOptions IO a)
  deriving newtype
    ( (forall a b. (a -> b) -> DirectBackend a -> DirectBackend b)
-> (forall a b. a -> DirectBackend b -> DirectBackend a)
-> Functor DirectBackend
forall a b. a -> DirectBackend b -> DirectBackend a
forall a b. (a -> b) -> DirectBackend a -> DirectBackend b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> DirectBackend a -> DirectBackend b
fmap :: forall a b. (a -> b) -> DirectBackend a -> DirectBackend b
$c<$ :: forall a b. a -> DirectBackend b -> DirectBackend a
<$ :: forall a b. a -> DirectBackend b -> DirectBackend a
Functor
    , Functor DirectBackend
Functor DirectBackend =>
(forall a. a -> DirectBackend a)
-> (forall a b.
    DirectBackend (a -> b) -> DirectBackend a -> DirectBackend b)
-> (forall a b c.
    (a -> b -> c)
    -> DirectBackend a -> DirectBackend b -> DirectBackend c)
-> (forall a b.
    DirectBackend a -> DirectBackend b -> DirectBackend b)
-> (forall a b.
    DirectBackend a -> DirectBackend b -> DirectBackend a)
-> Applicative DirectBackend
forall a. a -> DirectBackend a
forall a b. DirectBackend a -> DirectBackend b -> DirectBackend a
forall a b. DirectBackend a -> DirectBackend b -> DirectBackend b
forall a b.
DirectBackend (a -> b) -> DirectBackend a -> DirectBackend b
forall a b c.
(a -> b -> c)
-> DirectBackend a -> DirectBackend b -> DirectBackend c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> DirectBackend a
pure :: forall a. a -> DirectBackend a
$c<*> :: forall a b.
DirectBackend (a -> b) -> DirectBackend a -> DirectBackend b
<*> :: forall a b.
DirectBackend (a -> b) -> DirectBackend a -> DirectBackend b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> DirectBackend a -> DirectBackend b -> DirectBackend c
liftA2 :: forall a b c.
(a -> b -> c)
-> DirectBackend a -> DirectBackend b -> DirectBackend c
$c*> :: forall a b. DirectBackend a -> DirectBackend b -> DirectBackend b
*> :: forall a b. DirectBackend a -> DirectBackend b -> DirectBackend b
$c<* :: forall a b. DirectBackend a -> DirectBackend b -> DirectBackend a
<* :: forall a b. DirectBackend a -> DirectBackend b -> DirectBackend a
Applicative
    , Applicative DirectBackend
Applicative DirectBackend =>
(forall a b.
 DirectBackend a -> (a -> DirectBackend b) -> DirectBackend b)
-> (forall a b.
    DirectBackend a -> DirectBackend b -> DirectBackend b)
-> (forall a. a -> DirectBackend a)
-> Monad DirectBackend
forall a. a -> DirectBackend a
forall a b. DirectBackend a -> DirectBackend b -> DirectBackend b
forall a b.
DirectBackend a -> (a -> DirectBackend b) -> DirectBackend b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
DirectBackend a -> (a -> DirectBackend b) -> DirectBackend b
>>= :: forall a b.
DirectBackend a -> (a -> DirectBackend b) -> DirectBackend b
$c>> :: forall a b. DirectBackend a -> DirectBackend b -> DirectBackend b
>> :: forall a b. DirectBackend a -> DirectBackend b -> DirectBackend b
$creturn :: forall a. a -> DirectBackend a
return :: forall a. a -> DirectBackend a
Monad
    , Monad DirectBackend
Monad DirectBackend =>
(forall a. IO a -> DirectBackend a) -> MonadIO DirectBackend
forall a. IO a -> DirectBackend a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> DirectBackend a
liftIO :: forall a. IO a -> DirectBackend a
MonadIO
    , Monad DirectBackend
Monad DirectBackend =>
(forall e a. Exception e => e -> DirectBackend a)
-> (forall a b c.
    DirectBackend a
    -> (a -> DirectBackend b)
    -> (a -> DirectBackend c)
    -> DirectBackend c)
-> (forall a b c.
    DirectBackend a
    -> DirectBackend b -> DirectBackend c -> DirectBackend c)
-> (forall a b.
    DirectBackend a -> DirectBackend b -> DirectBackend a)
-> MonadThrow DirectBackend
forall e a. Exception e => e -> DirectBackend a
forall a b. DirectBackend a -> DirectBackend b -> DirectBackend a
forall a b c.
DirectBackend a
-> DirectBackend b -> DirectBackend c -> DirectBackend c
forall a b c.
DirectBackend a
-> (a -> DirectBackend b)
-> (a -> DirectBackend c)
-> DirectBackend c
forall (m :: * -> *).
Monad m =>
(forall e a. Exception e => e -> m a)
-> (forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c)
-> (forall a b c. m a -> m b -> m c -> m c)
-> (forall a b. m a -> m b -> m a)
-> MonadThrow m
$cthrowIO :: forall e a. Exception e => e -> DirectBackend a
throwIO :: forall e a. Exception e => e -> DirectBackend a
$cbracket :: forall a b c.
DirectBackend a
-> (a -> DirectBackend b)
-> (a -> DirectBackend c)
-> DirectBackend c
bracket :: forall a b c.
DirectBackend a
-> (a -> DirectBackend b)
-> (a -> DirectBackend c)
-> DirectBackend c
$cbracket_ :: forall a b c.
DirectBackend a
-> DirectBackend b -> DirectBackend c -> DirectBackend c
bracket_ :: forall a b c.
DirectBackend a
-> DirectBackend b -> DirectBackend c -> DirectBackend c
$cfinally :: forall a b. DirectBackend a -> DirectBackend b -> DirectBackend a
finally :: forall a b. DirectBackend a -> DirectBackend b -> DirectBackend a
MonadThrow
    , MonadThrow DirectBackend
MonadThrow DirectBackend =>
(forall e a.
 Exception e =>
 DirectBackend a -> (e -> DirectBackend a) -> DirectBackend a)
-> (forall e b a.
    Exception e =>
    (e -> Maybe b)
    -> DirectBackend a -> (b -> DirectBackend a) -> DirectBackend a)
-> (forall e a.
    Exception e =>
    DirectBackend a -> DirectBackend (Either e a))
-> (forall e b a.
    Exception e =>
    (e -> Maybe b) -> DirectBackend a -> DirectBackend (Either b a))
-> (forall e a.
    Exception e =>
    (e -> DirectBackend a) -> DirectBackend a -> DirectBackend a)
-> (forall e b a.
    Exception e =>
    (e -> Maybe b)
    -> (b -> DirectBackend a) -> DirectBackend a -> DirectBackend a)
-> (forall a b.
    DirectBackend a -> DirectBackend b -> DirectBackend a)
-> (forall a b c.
    DirectBackend a
    -> (a -> DirectBackend b)
    -> (a -> DirectBackend c)
    -> DirectBackend c)
-> (forall a b c.
    DirectBackend a
    -> (a -> ExitCase b -> DirectBackend c)
    -> (a -> DirectBackend b)
    -> DirectBackend (b, c))
-> MonadCatch DirectBackend
forall e a.
Exception e =>
DirectBackend a -> DirectBackend (Either e a)
forall e a.
Exception e =>
DirectBackend a -> (e -> DirectBackend a) -> DirectBackend a
forall e a.
Exception e =>
(e -> DirectBackend a) -> DirectBackend a -> DirectBackend a
forall a b. DirectBackend a -> DirectBackend b -> DirectBackend a
forall e b a.
Exception e =>
(e -> Maybe b) -> DirectBackend a -> DirectBackend (Either b a)
forall e b a.
Exception e =>
(e -> Maybe b)
-> DirectBackend a -> (b -> DirectBackend a) -> DirectBackend a
forall e b a.
Exception e =>
(e -> Maybe b)
-> (b -> DirectBackend a) -> DirectBackend a -> DirectBackend a
forall a b c.
DirectBackend a
-> (a -> DirectBackend b)
-> (a -> DirectBackend c)
-> DirectBackend c
forall a b c.
DirectBackend a
-> (a -> ExitCase b -> DirectBackend c)
-> (a -> DirectBackend b)
-> DirectBackend (b, c)
forall (m :: * -> *).
MonadThrow m =>
(forall e a. Exception e => m a -> (e -> m a) -> m a)
-> (forall e b a.
    Exception e =>
    (e -> Maybe b) -> m a -> (b -> m a) -> m a)
-> (forall e a. Exception e => m a -> m (Either e a))
-> (forall e b a.
    Exception e =>
    (e -> Maybe b) -> m a -> m (Either b a))
-> (forall e a. Exception e => (e -> m a) -> m a -> m a)
-> (forall e b a.
    Exception e =>
    (e -> Maybe b) -> (b -> m a) -> m a -> m a)
-> (forall a b. m a -> m b -> m a)
-> (forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadCatch m
$ccatch :: forall e a.
Exception e =>
DirectBackend a -> (e -> DirectBackend a) -> DirectBackend a
catch :: forall e a.
Exception e =>
DirectBackend a -> (e -> DirectBackend a) -> DirectBackend a
$ccatchJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> DirectBackend a -> (b -> DirectBackend a) -> DirectBackend a
catchJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> DirectBackend a -> (b -> DirectBackend a) -> DirectBackend a
$ctry :: forall e a.
Exception e =>
DirectBackend a -> DirectBackend (Either e a)
try :: forall e a.
Exception e =>
DirectBackend a -> DirectBackend (Either e a)
$ctryJust :: forall e b a.
Exception e =>
(e -> Maybe b) -> DirectBackend a -> DirectBackend (Either b a)
tryJust :: forall e b a.
Exception e =>
(e -> Maybe b) -> DirectBackend a -> DirectBackend (Either b a)
$chandle :: forall e a.
Exception e =>
(e -> DirectBackend a) -> DirectBackend a -> DirectBackend a
handle :: forall e a.
Exception e =>
(e -> DirectBackend a) -> DirectBackend a -> DirectBackend a
$chandleJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> (b -> DirectBackend a) -> DirectBackend a -> DirectBackend a
handleJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> (b -> DirectBackend a) -> DirectBackend a -> DirectBackend a
$conException :: forall a b. DirectBackend a -> DirectBackend b -> DirectBackend a
onException :: forall a b. DirectBackend a -> DirectBackend b -> DirectBackend a
$cbracketOnError :: forall a b c.
DirectBackend a
-> (a -> DirectBackend b)
-> (a -> DirectBackend c)
-> DirectBackend c
bracketOnError :: forall a b c.
DirectBackend a
-> (a -> DirectBackend b)
-> (a -> DirectBackend c)
-> DirectBackend c
$cgeneralBracket :: forall a b c.
DirectBackend a
-> (a -> ExitCase b -> DirectBackend c)
-> (a -> DirectBackend b)
-> DirectBackend (b, c)
generalBracket :: forall a b c.
DirectBackend a
-> (a -> ExitCase b -> DirectBackend c)
-> (a -> DirectBackend b)
-> DirectBackend (b, c)
MonadCatch
    )

runDirectBackend :: DirectOptions -> DirectBackend a -> IO a
runDirectBackend :: forall a. DirectOptions -> DirectBackend a -> IO a
runDirectBackend DirectOptions
opts (DirectBackend ReaderT DirectOptions IO a
m) = ReaderT DirectOptions IO a -> DirectOptions -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT DirectOptions IO a
m DirectOptions
opts

instance ChainBackend DirectBackend where
  queryGenesisParameters :: DirectBackend (GenesisParameters ShelleyEra)
queryGenesisParameters = (LocalNodeConnectInfo -> IO (GenesisParameters ShelleyEra))
-> DirectBackend (GenesisParameters ShelleyEra)
forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn ((LocalNodeConnectInfo -> IO (GenesisParameters ShelleyEra))
 -> DirectBackend (GenesisParameters ShelleyEra))
-> (LocalNodeConnectInfo -> IO (GenesisParameters ShelleyEra))
-> DirectBackend (GenesisParameters ShelleyEra)
forall a b. (a -> b) -> a -> b
$ \LocalNodeConnectInfo
ci ->
    LocalNodeConnectInfo
-> QueryPoint -> IO (GenesisParameters ShelleyEra)
CardanoClient.queryGenesisParameters LocalNodeConnectInfo
ci QueryPoint
CardanoClient.QueryTip

  queryScriptRegistry :: [TxId] -> DirectBackend ScriptRegistry
queryScriptRegistry = [TxId] -> DirectBackend ScriptRegistry
forall (m :: * -> *).
(ChainBackend m, MonadThrow m) =>
[TxId] -> m ScriptRegistry
ScriptRegistry.queryScriptRegistry

  queryNetworkId :: DirectBackend NetworkId
queryNetworkId = ReaderT DirectOptions IO NetworkId -> DirectBackend NetworkId
forall a. ReaderT DirectOptions IO a -> DirectBackend a
DirectBackend (ReaderT DirectOptions IO NetworkId -> DirectBackend NetworkId)
-> ReaderT DirectOptions IO NetworkId -> DirectBackend NetworkId
forall a b. (a -> b) -> a -> b
$ do
    DirectOptions{NetworkId
networkId :: NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId} <- ReaderT DirectOptions IO DirectOptions
forall r (m :: * -> *). MonadReader r m => m r
ask
    NetworkId -> ReaderT DirectOptions IO NetworkId
forall a. a -> ReaderT DirectOptions IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NetworkId
networkId

  queryTip :: DirectBackend ChainPoint
queryTip = (LocalNodeConnectInfo -> IO ChainPoint) -> DirectBackend ChainPoint
forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn LocalNodeConnectInfo -> IO ChainPoint
CardanoClient.queryTip

  queryUTxO :: [Address ShelleyAddr] -> DirectBackend UTxO
queryUTxO [Address ShelleyAddr]
addresses = (LocalNodeConnectInfo -> IO UTxO) -> DirectBackend UTxO
forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn ((LocalNodeConnectInfo -> IO UTxO) -> DirectBackend UTxO)
-> (LocalNodeConnectInfo -> IO UTxO) -> DirectBackend UTxO
forall a b. (a -> b) -> a -> b
$ \LocalNodeConnectInfo
ci ->
    LocalNodeConnectInfo
-> QueryPoint -> [Address ShelleyAddr] -> IO UTxO
CardanoClient.queryUTxO LocalNodeConnectInfo
ci QueryPoint
CardanoClient.QueryTip [Address ShelleyAddr]
addresses

  queryUTxOByTxIn :: [TxIn] -> DirectBackend UTxO
queryUTxOByTxIn [TxIn]
txins = (LocalNodeConnectInfo -> IO UTxO) -> DirectBackend UTxO
forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn ((LocalNodeConnectInfo -> IO UTxO) -> DirectBackend UTxO)
-> (LocalNodeConnectInfo -> IO UTxO) -> DirectBackend UTxO
forall a b. (a -> b) -> a -> b
$ \LocalNodeConnectInfo
ci ->
    LocalNodeConnectInfo -> QueryPoint -> [TxIn] -> IO UTxO
CardanoClient.queryUTxOByTxIn LocalNodeConnectInfo
ci QueryPoint
CardanoClient.QueryTip [TxIn]
txins

  queryEraHistory :: QueryPoint -> DirectBackend EraHistory
queryEraHistory QueryPoint
queryPoint = (LocalNodeConnectInfo -> IO EraHistory) -> DirectBackend EraHistory
forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn ((LocalNodeConnectInfo -> IO EraHistory)
 -> DirectBackend EraHistory)
-> (LocalNodeConnectInfo -> IO EraHistory)
-> DirectBackend EraHistory
forall a b. (a -> b) -> a -> b
$ \LocalNodeConnectInfo
ci ->
    LocalNodeConnectInfo -> QueryPoint -> IO EraHistory
CardanoClient.queryEraHistory LocalNodeConnectInfo
ci QueryPoint
queryPoint

  querySystemStart :: QueryPoint -> DirectBackend SystemStart
querySystemStart QueryPoint
queryPoint = (LocalNodeConnectInfo -> IO SystemStart)
-> DirectBackend SystemStart
forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn ((LocalNodeConnectInfo -> IO SystemStart)
 -> DirectBackend SystemStart)
-> (LocalNodeConnectInfo -> IO SystemStart)
-> DirectBackend SystemStart
forall a b. (a -> b) -> a -> b
$ \LocalNodeConnectInfo
ci ->
    LocalNodeConnectInfo -> QueryPoint -> IO SystemStart
CardanoClient.querySystemStart LocalNodeConnectInfo
ci QueryPoint
queryPoint

  queryProtocolParameters :: QueryPoint -> DirectBackend (PParams LedgerEra)
queryProtocolParameters QueryPoint
queryPoint = (LocalNodeConnectInfo -> IO (PParams LedgerEra))
-> DirectBackend (PParams LedgerEra)
forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn ((LocalNodeConnectInfo -> IO (PParams LedgerEra))
 -> DirectBackend (PParams LedgerEra))
-> (LocalNodeConnectInfo -> IO (PParams LedgerEra))
-> DirectBackend (PParams LedgerEra)
forall a b. (a -> b) -> a -> b
$ \LocalNodeConnectInfo
ci ->
    LocalNodeConnectInfo -> QueryPoint -> IO (PParams LedgerEra)
CardanoClient.queryProtocolParameters LocalNodeConnectInfo
ci QueryPoint
queryPoint

  queryStakePools :: QueryPoint -> DirectBackend (Set PoolId)
queryStakePools QueryPoint
queryPoint = (LocalNodeConnectInfo -> IO (Set PoolId))
-> DirectBackend (Set PoolId)
forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn ((LocalNodeConnectInfo -> IO (Set PoolId))
 -> DirectBackend (Set PoolId))
-> (LocalNodeConnectInfo -> IO (Set PoolId))
-> DirectBackend (Set PoolId)
forall a b. (a -> b) -> a -> b
$ \LocalNodeConnectInfo
ci ->
    LocalNodeConnectInfo -> QueryPoint -> IO (Set PoolId)
CardanoClient.queryStakePools LocalNodeConnectInfo
ci QueryPoint
queryPoint

  queryUTxOFor :: QueryPoint -> VerificationKey PaymentKey -> DirectBackend UTxO
queryUTxOFor QueryPoint
queryPoint VerificationKey PaymentKey
vk = (LocalNodeConnectInfo -> IO UTxO) -> DirectBackend UTxO
forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn ((LocalNodeConnectInfo -> IO UTxO) -> DirectBackend UTxO)
-> (LocalNodeConnectInfo -> IO UTxO) -> DirectBackend UTxO
forall a b. (a -> b) -> a -> b
$ \LocalNodeConnectInfo
ci ->
    LocalNodeConnectInfo
-> QueryPoint -> VerificationKey PaymentKey -> IO UTxO
CardanoClient.queryUTxOFor LocalNodeConnectInfo
ci QueryPoint
queryPoint VerificationKey PaymentKey
vk

  submitTransaction :: Tx -> DirectBackend ()
submitTransaction Tx
tx = (LocalNodeConnectInfo -> IO ()) -> DirectBackend ()
forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn ((LocalNodeConnectInfo -> IO ()) -> DirectBackend ())
-> (LocalNodeConnectInfo -> IO ()) -> DirectBackend ()
forall a b. (a -> b) -> a -> b
$ \LocalNodeConnectInfo
ci ->
    LocalNodeConnectInfo -> Tx -> IO ()
CardanoClient.submitTransaction LocalNodeConnectInfo
ci Tx
tx

  awaitTransaction :: Tx -> VerificationKey PaymentKey -> DirectBackend UTxO
awaitTransaction Tx
tx VerificationKey PaymentKey
_ = (LocalNodeConnectInfo -> IO UTxO) -> DirectBackend UTxO
forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn ((LocalNodeConnectInfo -> IO UTxO) -> DirectBackend UTxO)
-> (LocalNodeConnectInfo -> IO UTxO) -> DirectBackend UTxO
forall a b. (a -> b) -> a -> b
$ \LocalNodeConnectInfo
ci ->
    LocalNodeConnectInfo -> Tx -> IO UTxO
CardanoClient.awaitTransaction LocalNodeConnectInfo
ci Tx
tx

  getBlockTime :: DirectBackend NominalDiffTime
getBlockTime = (LocalNodeConnectInfo -> IO NominalDiffTime)
-> DirectBackend NominalDiffTime
forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn ((LocalNodeConnectInfo -> IO NominalDiffTime)
 -> DirectBackend NominalDiffTime)
-> (LocalNodeConnectInfo -> IO NominalDiffTime)
-> DirectBackend NominalDiffTime
forall a b. (a -> b) -> a -> b
$ \LocalNodeConnectInfo
ci ->
    LocalNodeConnectInfo -> QueryPoint -> IO NominalDiffTime
CardanoClient.queryBlockTime LocalNodeConnectInfo
ci QueryPoint
CardanoClient.QueryTip

withNodeConn :: (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn :: forall a. (LocalNodeConnectInfo -> IO a) -> DirectBackend a
withNodeConn LocalNodeConnectInfo -> IO a
f = ReaderT DirectOptions IO a -> DirectBackend a
forall a. ReaderT DirectOptions IO a -> DirectBackend a
DirectBackend (ReaderT DirectOptions IO a -> DirectBackend a)
-> ReaderT DirectOptions IO a -> DirectBackend a
forall a b. (a -> b) -> a -> b
$ do
  DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
nodeSocket :: SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket} <- ReaderT DirectOptions IO DirectOptions
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO a -> ReaderT DirectOptions IO a
forall a. IO a -> ReaderT DirectOptions IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderT DirectOptions IO a)
-> IO a -> ReaderT DirectOptions IO a
forall a b. (a -> b) -> a -> b
$ LocalNodeConnectInfo -> IO a
f (NetworkId -> SocketPath -> LocalNodeConnectInfo
CardanoClient.localNodeConnectInfo NetworkId
networkId SocketPath
nodeSocket)

withDirectChain ::
  DirectOptions ->
  Tracer IO CardanoChainLog ->
  CardanoChainConfig ->
  ChainContext ->
  TinyWallet IO ->
  -- | Chain state loaded from persistence.
  ChainStateHistory Tx ->
  ChainComponent Tx IO a
withDirectChain :: forall a.
DirectOptions
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> ChainContext
-> TinyWallet IO
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
withDirectChain DirectOptions
opts 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
  -- Known points on chain as loaded from persistence.
  let persistedPoints :: NonEmpty (ChainPointType Tx)
persistedPoints = ChainStateHistory Tx -> NonEmpty (ChainPointType Tx)
forall tx.
IsChainState tx =>
ChainStateHistory tx -> NonEmpty (ChainPointType tx)
prefixOf ChainStateHistory Tx
chainStateHistory

  -- Select a prefix chain from which to start synchronizing
  let (NonEmpty ChainPoint
startFromPrefix, StartingDecision
startingDecision) =
        -- Only use start chain from if its more recent than persisted points.
        case Maybe ChainPoint
startChainFrom of
          Just ChainPoint
sc
            | ChainPoint
sc ChainPoint -> ChainPoint -> Bool
forall a. Ord a => a -> a -> Bool
> NonEmpty ChainPoint -> ChainPoint
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty ChainPoint
NonEmpty (ChainPointType Tx)
persistedPoints -> (ChainPoint
sc ChainPoint -> [ChainPoint] -> NonEmpty ChainPoint
forall a. a -> [a] -> NonEmpty a
:| [], ChainPoint -> StartingDecision
FromProvided ChainPoint
sc)
            | Bool
otherwise -> (NonEmpty ChainPoint
NonEmpty (ChainPointType Tx)
persistedPoints, ChainPoint -> Bool -> StartingDecision
FromPersisted (NonEmpty ChainPoint -> ChainPoint
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty ChainPoint
NonEmpty (ChainPointType Tx)
persistedPoints) Bool
True)
          Maybe ChainPoint
_ -> (NonEmpty ChainPoint
NonEmpty (ChainPointType Tx)
persistedPoints, ChainPoint -> Bool -> StartingDecision
FromPersisted (NonEmpty ChainPoint -> ChainPoint
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty ChainPoint
NonEmpty (ChainPointType Tx)
persistedPoints) Bool
False)

  -- Use the tip if we would otherwise start at the genesis (it can't be a good choice).
  (NonEmpty ChainPoint
prefix, StartingDecision
startingDecision') <-
    case NonEmpty ChainPoint -> ChainPoint
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty ChainPoint
startFromPrefix of
      ChainPoint
ChainPointAtGenesis -> do
        ChainPoint
tip <- DirectOptions -> DirectBackend ChainPoint -> IO ChainPoint
forall a. DirectOptions -> DirectBackend a -> IO a
runDirectBackend DirectOptions
opts DirectBackend ChainPoint
forall (m :: * -> *). ChainBackend m => m ChainPoint
queryTip
        (NonEmpty ChainPoint, StartingDecision)
-> IO (NonEmpty ChainPoint, StartingDecision)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainPoint
tip ChainPoint -> [ChainPoint] -> NonEmpty ChainPoint
forall a. a -> [a] -> NonEmpty a
:| [], ChainPoint -> StartingDecision
FromTip ChainPoint
tip)
      ChainPoint
_ -> (NonEmpty ChainPoint, StartingDecision)
-> IO (NonEmpty ChainPoint, StartingDecision)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty ChainPoint
startFromPrefix, StartingDecision
startingDecision)

  Tracer IO CardanoChainLog -> CardanoChainLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO CardanoChainLog
tracer (CardanoChainLog -> IO ()) -> CardanoChainLog -> IO ()
forall a b. (a -> b) -> a -> b
$ StartingDecision -> CardanoChainLog
StartingChainDecision StartingDecision
startingDecision'
  let getTimeHandle :: IO TimeHandle
getTimeHandle = DirectOptions -> DirectBackend TimeHandle -> IO TimeHandle
forall a. DirectOptions -> DirectBackend a -> IO a
runDirectBackend DirectOptions
opts DirectBackend TimeHandle
forall (m :: * -> *). (ChainBackend m, Monad m) => m TimeHandle
queryTimeHandle
  SlotNo -> IO TimeHandle
cachedTimeHandle <- (forall a. DirectBackend a -> IO a) -> IO (SlotNo -> IO TimeHandle)
forall (backend :: * -> *).
ChainBackend backend =>
(forall a. backend a -> IO a) -> IO (SlotNo -> IO TimeHandle)
newCachedTimeHandle (DirectOptions -> DirectBackend a -> IO a
forall a. DirectOptions -> DirectBackend a -> IO a
runDirectBackend DirectOptions
opts)
  LocalChainState IO Tx
localChainState <- ChainStateHistory Tx -> IO (LocalChainState IO Tx)
forall (m :: * -> *) tx.
(IsChainState tx, MonadLabelledSTM m) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState ChainStateHistory Tx
chainStateHistory
  TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
queue <- String -> IO (TQueue IO (Tx, TMVar (Maybe (PostTxError Tx))))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TQueue m a)
newLabelledTQueueIO String
"direct-chain-queue"
  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 ()
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
-> (SlotNo -> IO TimeHandle)
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m CardanoChainLog
-> ChainCallback Tx m
-> (SlotNo -> GetTimeHandle m)
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler Tracer IO CardanoChainLog
tracer ChainCallback Tx IO
callback SlotNo -> IO TimeHandle
cachedTimeHandle ChainContext
ctx LocalChainState IO Tx
localChainState
  Either () a
res <-
    (String, IO ()) -> (String, IO a) -> IO (Either () a)
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (String, m b) -> m (Either a b)
raceLabelled
      ( String
"direct-chain-connection"
      , (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
$ do
          LocalNodeConnectInfo -> LocalNodeClientProtocolsInMode -> IO ()
forall (m :: * -> *).
MonadIO m =>
LocalNodeConnectInfo -> LocalNodeClientProtocolsInMode -> m ()
connectToLocalNode
            (NetworkId -> SocketPath -> LocalNodeConnectInfo
connectInfo NetworkId
networkId SocketPath
nodeSocket)
            (NonEmpty ChainPoint
-> TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
-> ChainSyncHandler IO
-> LocalNodeClientProtocolsInMode
clientProtocols NonEmpty ChainPoint
prefix TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
queue ChainSyncHandler IO
handler)
      )
      (String
"direct-chain-chain-handle", 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
  DirectOptions{NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket} = DirectOptions
opts
  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 :: NonEmpty ChainPoint
-> TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
-> ChainSyncHandler IO
-> LocalNodeClientProtocolsInMode
clientProtocols NonEmpty ChainPoint
prefix TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
queue ChainSyncHandler IO
handler =
    LocalNodeClientProtocols
      { localChainSyncClient :: LocalChainSyncClient BlockType ChainPoint ChainTip IO
localChainSyncClient = ChainSyncClient BlockType ChainPoint ChainTip IO ()
-> LocalChainSyncClient BlockType ChainPoint ChainTip IO
forall block point tip (m :: * -> *).
ChainSyncClient block point tip m ()
-> LocalChainSyncClient block point tip m
LocalChainSyncClient (ChainSyncClient BlockType ChainPoint ChainTip IO ()
 -> LocalChainSyncClient BlockType ChainPoint ChainTip IO)
-> ChainSyncClient BlockType ChainPoint ChainTip IO ()
-> LocalChainSyncClient BlockType ChainPoint ChainTip IO
forall a b. (a -> b) -> a -> b
$ ChainSyncHandler IO
-> TinyWallet IO
-> NonEmpty ChainPoint
-> ChainSyncClient BlockType ChainPoint ChainTip IO ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
ChainSyncHandler m
-> TinyWallet m
-> NonEmpty ChainPoint
-> ChainSyncClient BlockType ChainPoint ChainTip m ()
chainSyncClient ChainSyncHandler IO
handler TinyWallet IO
wallet NonEmpty ChainPoint
prefix
      , 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
-> IO NominalDiffTime
-> TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
-> LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode IO ()
forall (m :: * -> *).
(MonadSTM m, MonadDelay m) =>
Tracer m CardanoChainLog
-> m NominalDiffTime
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode m ()
txSubmissionClient Tracer IO CardanoChainLog
tracer (DirectOptions
-> DirectBackend NominalDiffTime -> IO NominalDiffTime
forall a. DirectOptions -> DirectBackend a -> IO a
runDirectBackend DirectOptions
opts DirectBackend NominalDiffTime
forall (m :: * -> *). ChainBackend m => m NominalDiffTime
getBlockTime) TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
queue
      , localStateQueryClient :: Maybe
  (LocalStateQueryClient BlockType ChainPoint QueryInMode IO ())
localStateQueryClient = Maybe
  (LocalStateQueryClient BlockType 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 IO (Tx, TMVar IO (Maybe (PostTxError Tx))) -> Tx -> IO ()
  submitTx :: TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx))) -> Tx -> IO ()
submitTx TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
queue Tx
tx = do
    TMVar IO (Maybe (PostTxError Tx))
response <- STM IO (TMVar IO (Maybe (PostTxError Tx)))
-> IO (TMVar IO (Maybe (PostTxError Tx)))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (TMVar IO (Maybe (PostTxError Tx)))
 -> IO (TMVar IO (Maybe (PostTxError Tx))))
-> STM IO (TMVar IO (Maybe (PostTxError Tx)))
-> IO (TMVar IO (Maybe (PostTxError Tx)))
forall a b. (a -> b) -> a -> b
$ do
      TMVar IO (Maybe (PostTxError Tx))
response <- String -> STM IO (TMVar IO (Maybe (PostTxError Tx)))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> STM m (TMVar m a)
newLabelledEmptyTMVar String
"direct-chain-submit-tx-response"
      TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
-> (Tx, TMVar IO (Maybe (PostTxError Tx))) -> STM IO ()
forall a. TQueue IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
queue (Tx
tx, TMVar IO (Maybe (PostTxError Tx))
response)
      TMVar IO (Maybe (PostTxError Tx))
-> STM (TMVar IO (Maybe (PostTxError Tx)))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return TMVar IO (Maybe (PostTxError Tx))
response
    STM IO (Maybe (PostTxError Tx)) -> IO (Maybe (PostTxError Tx))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TMVar IO (Maybe (PostTxError Tx))
-> STM IO (Maybe (PostTxError Tx))
forall a. TMVar IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
takeTMVar TMVar IO (Maybe (PostTxError Tx))
response)
      IO (Maybe (PostTxError Tx))
-> (Maybe (PostTxError Tx) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO ()
-> (PostTxError Tx -> IO ()) -> Maybe (PostTxError Tx) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) PostTxError Tx -> IO ()
forall e a. Exception e => e -> IO 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 points of intersection are unknown to
-- the local node. This may happen if users shut down their node quickly after
-- starting them and hold on not-so-stable points of the chain. When they turn
-- the node back on, those points may no longer exist on the network if a fork
-- with deeper roots has been adopted in the meantime.
newtype IntersectionNotFoundException = IntersectionNotFound
  { IntersectionNotFoundException -> NonEmpty ChainPoint
requestedPoints :: NonEmpty 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 where
  displayException :: IntersectionNotFoundException -> String
displayException (IntersectionNotFound NonEmpty ChainPoint
points) =
    String -> ShowS
forall r. PrintfType r => String -> r
printf
      String
"None of the requested intersection points %s were found on the local node.\n\
      \Requested points (newest first):\n\
      \%s\n\
      \This may happen if the points are too recent and the node has not yet \
      \synchronized that far, or if they are too old and have been pruned \
      \from the local node. Please try again with a different points."
      String
requestedPoints
   where
    requestedPoints :: String
    requestedPoints :: String
requestedPoints = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ((ChainPoint -> Text) -> [ChainPoint] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChainPoint -> Text
forall b a. (Show a, IsString b) => a -> b
show (NonEmpty ChainPoint -> [ChainPoint]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty ChainPoint
points))

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

  clientStIdle :: ClientStIdle BlockType ChainPoint ChainTip m ()
  clientStIdle :: ClientStIdle BlockType ChainPoint ChainTip m ()
clientStIdle = m ()
-> ClientStNext BlockType ChainPoint ChainTip m ()
-> ClientStIdle BlockType 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 BlockType ChainPoint ChainTip m ()
clientStNext

  clientStNext :: ClientStNext BlockType ChainPoint ChainTip m ()
  clientStNext :: ClientStNext BlockType ChainPoint ChainTip m ()
clientStNext =
    ClientStNext
      { recvMsgRollForward :: BlockType
-> ChainTip -> ChainSyncClient BlockType ChainPoint ChainTip m ()
recvMsgRollForward = \BlockType
blockInMode ChainTip
_tip -> m (ClientStIdle BlockType ChainPoint ChainTip m ())
-> ChainSyncClient BlockType 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 BlockType ChainPoint ChainTip m ())
 -> ChainSyncClient BlockType ChainPoint ChainTip m ())
-> m (ClientStIdle BlockType ChainPoint ChainTip m ())
-> ChainSyncClient BlockType ChainPoint ChainTip m ()
forall a b. (a -> b) -> a -> b
$ do
          case BlockType
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 BlockType ChainPoint ChainTip m ()
-> m (ClientStIdle BlockType ChainPoint ChainTip m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle BlockType ChainPoint ChainTip m ()
clientStIdle
            BlockInMode era :: CardanoEra era
era@CardanoEra era
DijkstraEra Block era
_ -> EraNotSupportedException
-> m (ClientStIdle BlockType 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 BlockType ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockType ChainPoint ChainTip m ())
forall a b. (a -> b) -> a -> b
$ EraNotSupportedYet{$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
BabbageEra Block era
_ -> EraNotSupportedException
-> m (ClientStIdle BlockType 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 BlockType ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockType 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 BlockType 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 BlockType ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockType 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 BlockType 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 BlockType ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockType 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 BlockType 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 BlockType ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockType 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 BlockType 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 BlockType ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockType 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 BlockType 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 BlockType ChainPoint ChainTip m ()))
-> EraNotSupportedException
-> m (ClientStIdle BlockType 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 BlockType ChainPoint ChainTip m ()
recvMsgRollBackward = \ChainPoint
point ChainTip
_tip -> m (ClientStIdle BlockType ChainPoint ChainTip m ())
-> ChainSyncClient BlockType 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 BlockType ChainPoint ChainTip m ())
 -> ChainSyncClient BlockType ChainPoint ChainTip m ())
-> m (ClientStIdle BlockType ChainPoint ChainTip m ())
-> ChainSyncClient BlockType 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 BlockType ChainPoint ChainTip m ()
-> m (ClientStIdle BlockType ChainPoint ChainTip m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle BlockType ChainPoint ChainTip m ()
clientStIdle
      }

txSubmissionClient ::
  forall m.
  (MonadSTM m, MonadDelay m) =>
  Tracer m CardanoChainLog ->
  -- | Action returning the chain's average block time (seconds), used to size
  -- the delay before reporting 'PostTxError' so the observing side has a chance
  -- to process a competing transaction.
  m NominalDiffTime ->
  TQueue m (Tx, TMVar m (Maybe (PostTxError Tx))) ->
  LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode m ()
txSubmissionClient :: forall (m :: * -> *).
(MonadSTM m, MonadDelay m) =>
Tracer m CardanoChainLog
-> m NominalDiffTime
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode m ()
txSubmissionClient Tracer m CardanoChainLog
tracer m NominalDiffTime
queryBlockTime 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 for one block time so the observing side
              -- has a chance to process a competing transaction; business
              -- logic might then ignore this error.
              NominalDiffTime
blockTime <- m NominalDiffTime
queryBlockTime
              DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
blockTime)
              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
        )