{-# 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 Control.Tracer.JSON (Tracer, traceWith)
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.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
-> DepositPeriod
-> LocalChainState IO Tx
-> (Tx -> IO ())
-> Chain Tx IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
Tracer m CardanoChainLog
-> GetTimeHandle m
-> TinyWallet m
-> ChainContext
-> DepositPeriod
-> LocalChainState m Tx
-> SubmitTx m
-> Chain Tx m
mkChain
          Tracer IO CardanoChainLog
tracer
          IO TimeHandle
getTimeHandle
          TinyWallet IO
wallet
          ChainContext
ctx
          DepositPeriod
depositPeriod
          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, DepositPeriod
depositPeriod :: DepositPeriod
$sel:depositPeriod:CardanoChainConfig :: CardanoChainConfig -> DepositPeriod
depositPeriod} = 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
        )