{-# LANGUAGE DerivingStrategies   #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE UndecidableInstances #-}
{-| A node client that waits for a transaction to appear on the chain
-}
module Convex.NodeClient.WaitForTxnClient(
  runWaitForTxn,
  MonadBlockchainWaitingT(..),
  runMonadBlockchainWaitingT
) where

import           Cardano.Api                (BlockInMode, CardanoMode,
                                             ChainPoint, Env,
                                             LocalNodeConnectInfo, TxId)
import qualified Cardano.Api                as C
import           Control.Concurrent         (forkIO)
import           Control.Concurrent.STM     (TMVar, atomically, newEmptyTMVar,
                                             putTMVar, takeTMVar)
import           Control.Monad.Except       (MonadError (..))
import           Control.Monad.IO.Class     (MonadIO (..))
import           Control.Monad.Reader       (MonadTrans, ReaderT (..), ask,
                                             lift)
import           Convex.Class               (MonadBlockchain (..))
import           Convex.MonadLog            (MonadLog (..), logInfoS)
import           Convex.NodeClient.Fold     (CatchingUp (..), foldClient)
import           Convex.NodeClient.Resuming (resumingClient)
import           Convex.NodeClient.Types    (PipelinedLedgerStateClient,
                                             protocols)
import qualified Convex.NodeQueries         as NodeQueries

{-| Start a 'waitForTxnClient' in a separate thread. Returns a TMVar that will contain the block that has the given
transaction.
-}
runWaitForTxn :: LocalNodeConnectInfo CardanoMode -> Env -> TxId -> IO (TMVar (BlockInMode CardanoMode))
runWaitForTxn :: LocalNodeConnectInfo CardanoMode
-> Env -> TxId -> IO (TMVar (BlockInMode CardanoMode))
runWaitForTxn LocalNodeConnectInfo CardanoMode
connectInfo Env
env TxId
txi = do
  ChainPoint
tip' <- LocalNodeConnectInfo CardanoMode -> IO ChainPoint
NodeQueries.queryTip LocalNodeConnectInfo CardanoMode
connectInfo
  TMVar (BlockInMode CardanoMode)
tmv <- forall a. STM a -> IO a
atomically forall a. STM (TMVar a)
newEmptyTMVar
  ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall mode.
LocalNodeConnectInfo mode
-> LocalNodeClientProtocolsInMode mode -> IO ()
C.connectToLocalNode LocalNodeConnectInfo CardanoMode
connectInfo (PipelinedLedgerStateClient
-> LocalNodeClientProtocolsInMode CardanoMode
protocols forall a b. (a -> b) -> a -> b
$ TMVar (BlockInMode CardanoMode)
-> ChainPoint -> TxId -> Env -> PipelinedLedgerStateClient
waitForTxnClient TMVar (BlockInMode CardanoMode)
tmv ChainPoint
tip' TxId
txi Env
env)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure TMVar (BlockInMode CardanoMode)
tmv

{-| Scan the new blocks until the transaction appears
-}
waitForTxnClient :: TMVar (BlockInMode CardanoMode) -> ChainPoint -> TxId -> Env -> PipelinedLedgerStateClient
waitForTxnClient :: TMVar (BlockInMode CardanoMode)
-> ChainPoint -> TxId -> Env -> PipelinedLedgerStateClient
waitForTxnClient TMVar (BlockInMode CardanoMode)
tmv ChainPoint
cp TxId
txId Env
env =
  [ChainPoint]
-> (ResumingFrom -> PipelinedLedgerStateClient)
-> PipelinedLedgerStateClient
resumingClient [ChainPoint
cp] forall a b. (a -> b) -> a -> b
$ \ResumingFrom
_ ->
    forall s.
s
-> Env
-> (CatchingUp -> s -> BlockInMode CardanoMode -> IO (Maybe s))
-> PipelinedLedgerStateClient
foldClient () Env
env (TMVar (BlockInMode CardanoMode)
-> TxId
-> CatchingUp
-> ()
-> BlockInMode CardanoMode
-> IO (Maybe ())
applyBlock TMVar (BlockInMode CardanoMode)
tmv TxId
txId)

applyBlock :: TMVar (BlockInMode CardanoMode) -> TxId -> CatchingUp -> () -> BlockInMode CardanoMode -> IO (Maybe ())
applyBlock :: TMVar (BlockInMode CardanoMode)
-> TxId
-> CatchingUp
-> ()
-> BlockInMode CardanoMode
-> IO (Maybe ())
applyBlock TMVar (BlockInMode CardanoMode)
tmv TxId
txi CatchingUp
_ () BlockInMode CardanoMode
block = do
  case BlockInMode CardanoMode
block of
    C.BlockInMode Block era
blck EraInMode era CardanoMode
C.BabbageEraInCardanoMode ->
      if TxId -> Block BabbageEra -> Bool
checkTxIds TxId
txi Block era
blck
        then do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar (BlockInMode CardanoMode)
tmv BlockInMode CardanoMode
block
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just ())
    BlockInMode CardanoMode
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just ())

checkTxIds :: TxId -> C.Block C.BabbageEra -> Bool
checkTxIds :: TxId -> Block BabbageEra -> Bool
checkTxIds TxId
txi ((C.Block BlockHeader
_ [Tx BabbageEra]
txns)) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TxId -> Tx BabbageEra -> Bool
checkTxId TxId
txi) [Tx BabbageEra]
txns

checkTxId :: TxId -> C.Tx C.BabbageEra -> Bool
checkTxId :: TxId -> Tx BabbageEra -> Bool
checkTxId TxId
txi Tx BabbageEra
tx = TxId
txi forall a. Eq a => a -> a -> Bool
== forall era. TxBody era -> TxId
C.getTxId (forall era. Tx era -> TxBody era
C.getTxBody Tx BabbageEra
tx)

newtype MonadBlockchainWaitingT m a = MonadBlockchainWaitingT{forall (m :: * -> *) a.
MonadBlockchainWaitingT m a
-> ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a
unMonadBlockchainWaitingT :: ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a }
  deriving newtype (forall a b.
a -> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m a
forall a b.
(a -> b)
-> MonadBlockchainWaitingT m a -> MonadBlockchainWaitingT m b
forall (m :: * -> *) a b.
Functor m =>
a -> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b)
-> MonadBlockchainWaitingT m a -> MonadBlockchainWaitingT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b.
a -> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m a
fmap :: forall a b.
(a -> b)
-> MonadBlockchainWaitingT m a -> MonadBlockchainWaitingT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b)
-> MonadBlockchainWaitingT m a -> MonadBlockchainWaitingT m b
Functor, forall a. a -> MonadBlockchainWaitingT m a
forall a b.
MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m a
forall a b.
MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m b
forall a b.
MonadBlockchainWaitingT m (a -> b)
-> MonadBlockchainWaitingT m a -> MonadBlockchainWaitingT m b
forall a b c.
(a -> b -> c)
-> MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b
-> MonadBlockchainWaitingT m 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
forall {m :: * -> *}.
Applicative m =>
Functor (MonadBlockchainWaitingT m)
forall (m :: * -> *) a.
Applicative m =>
a -> MonadBlockchainWaitingT m a
forall (m :: * -> *) a b.
Applicative m =>
MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m a
forall (m :: * -> *) a b.
Applicative m =>
MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m b
forall (m :: * -> *) a b.
Applicative m =>
MonadBlockchainWaitingT m (a -> b)
-> MonadBlockchainWaitingT m a -> MonadBlockchainWaitingT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b
-> MonadBlockchainWaitingT m c
<* :: forall a b.
MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m a
*> :: forall a b.
MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m b
liftA2 :: forall a b c.
(a -> b -> c)
-> MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b
-> MonadBlockchainWaitingT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b
-> MonadBlockchainWaitingT m c
<*> :: forall a b.
MonadBlockchainWaitingT m (a -> b)
-> MonadBlockchainWaitingT m a -> MonadBlockchainWaitingT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
MonadBlockchainWaitingT m (a -> b)
-> MonadBlockchainWaitingT m a -> MonadBlockchainWaitingT m b
pure :: forall a. a -> MonadBlockchainWaitingT m a
$cpure :: forall (m :: * -> *) a.
Applicative m =>
a -> MonadBlockchainWaitingT m a
Applicative, forall a. a -> MonadBlockchainWaitingT m a
forall a b.
MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m b
forall a b.
MonadBlockchainWaitingT m a
-> (a -> MonadBlockchainWaitingT m b)
-> MonadBlockchainWaitingT m b
forall {m :: * -> *}.
Monad m =>
Applicative (MonadBlockchainWaitingT m)
forall (m :: * -> *) a. Monad m => a -> MonadBlockchainWaitingT m a
forall (m :: * -> *) a b.
Monad m =>
MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m b
forall (m :: * -> *) a b.
Monad m =>
MonadBlockchainWaitingT m a
-> (a -> MonadBlockchainWaitingT m b)
-> MonadBlockchainWaitingT m 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
return :: forall a. a -> MonadBlockchainWaitingT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> MonadBlockchainWaitingT m a
>> :: forall a b.
MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
MonadBlockchainWaitingT m a
-> MonadBlockchainWaitingT m b -> MonadBlockchainWaitingT m b
>>= :: forall a b.
MonadBlockchainWaitingT m a
-> (a -> MonadBlockchainWaitingT m b)
-> MonadBlockchainWaitingT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
MonadBlockchainWaitingT m a
-> (a -> MonadBlockchainWaitingT m b)
-> MonadBlockchainWaitingT m b
Monad, forall a. IO a -> MonadBlockchainWaitingT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}.
MonadIO m =>
Monad (MonadBlockchainWaitingT m)
forall (m :: * -> *) a.
MonadIO m =>
IO a -> MonadBlockchainWaitingT m a
liftIO :: forall a. IO a -> MonadBlockchainWaitingT m a
$cliftIO :: forall (m :: * -> *) a.
MonadIO m =>
IO a -> MonadBlockchainWaitingT m a
MonadIO, forall a. String -> MonadBlockchainWaitingT m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall {m :: * -> *}.
MonadFail m =>
Monad (MonadBlockchainWaitingT m)
forall (m :: * -> *) a.
MonadFail m =>
String -> MonadBlockchainWaitingT m a
fail :: forall a. String -> MonadBlockchainWaitingT m a
$cfail :: forall (m :: * -> *) a.
MonadFail m =>
String -> MonadBlockchainWaitingT m a
MonadFail)

runMonadBlockchainWaitingT :: LocalNodeConnectInfo CardanoMode -> Env -> MonadBlockchainWaitingT m a -> m a
runMonadBlockchainWaitingT :: forall (m :: * -> *) a.
LocalNodeConnectInfo CardanoMode
-> Env -> MonadBlockchainWaitingT m a -> m a
runMonadBlockchainWaitingT LocalNodeConnectInfo CardanoMode
connectInfo Env
env (MonadBlockchainWaitingT ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a
action) = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a
action (LocalNodeConnectInfo CardanoMode
connectInfo, Env
env)

instance MonadError e m => MonadError e (MonadBlockchainWaitingT m) where
  throwError :: forall a. e -> MonadBlockchainWaitingT m a
throwError = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: forall a.
MonadBlockchainWaitingT m a
-> (e -> MonadBlockchainWaitingT m a)
-> MonadBlockchainWaitingT m a
catchError MonadBlockchainWaitingT m a
m e -> MonadBlockchainWaitingT m a
_ = MonadBlockchainWaitingT m a
m

instance MonadTrans MonadBlockchainWaitingT where
  lift :: forall (m :: * -> *) a.
Monad m =>
m a -> MonadBlockchainWaitingT m a
lift = forall (m :: * -> *) a.
ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a
-> MonadBlockchainWaitingT m a
MonadBlockchainWaitingT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance (MonadLog m) => MonadLog (MonadBlockchainWaitingT m) where
  logInfo' :: Doc Void -> MonadBlockchainWaitingT m ()
logInfo' = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadLog m => Doc Void -> m ()
logInfo'
  logWarn' :: Doc Void -> MonadBlockchainWaitingT m ()
logWarn' = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadLog m => Doc Void -> m ()
logWarn'
  logDebug' :: Doc Void -> MonadBlockchainWaitingT m ()
logDebug' = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadLog m => Doc Void -> m ()
logDebug'

instance (MonadIO m, MonadBlockchain m, MonadLog m) => MonadBlockchain (MonadBlockchainWaitingT m) where
  sendTx :: Tx BabbageEra -> MonadBlockchainWaitingT m TxId
sendTx Tx BabbageEra
tx = forall (m :: * -> *) a.
ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a
-> MonadBlockchainWaitingT m a
MonadBlockchainWaitingT forall a b. (a -> b) -> a -> b
$ do
    let txi :: TxId
txi = forall era. TxBody era -> TxId
C.getTxId (forall era. Tx era -> TxBody era
C.getTxBody Tx BabbageEra
tx)
    (LocalNodeConnectInfo CardanoMode
info, Env
env) <- forall r (m :: * -> *). MonadReader r m => m r
ask
    TMVar (BlockInMode CardanoMode)
tmv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LocalNodeConnectInfo CardanoMode
-> Env -> TxId -> IO (TMVar (BlockInMode CardanoMode))
runWaitForTxn LocalNodeConnectInfo CardanoMode
info Env
env TxId
txi)
    TxId
k <- forall (m :: * -> *). MonadBlockchain m => Tx BabbageEra -> m TxId
sendTx Tx BabbageEra
tx
    forall (m :: * -> *). MonadLog m => String -> m ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"MonadBlockchainWaitingT.sendTx: Waiting for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TxId
txi forall a. Semigroup a => a -> a -> a
<> String
" to appear on the chain"
    BlockInMode CardanoMode
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar TMVar (BlockInMode CardanoMode)
tmv)
    forall (m :: * -> *). MonadLog m => String -> m ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"MonadBlockchainWaitingT.sendTx: Found " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TxId
txi
    forall (f :: * -> *) a. Applicative f => a -> f a
pure TxId
k

  utxoByTxIn :: Set TxIn -> MonadBlockchainWaitingT m (UTxO BabbageEra)
utxoByTxIn Set TxIn
txIns = forall (m :: * -> *) a.
ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a
-> MonadBlockchainWaitingT m a
MonadBlockchainWaitingT (forall (m :: * -> *).
MonadBlockchain m =>
Set TxIn -> m (UTxO BabbageEra)
utxoByTxIn Set TxIn
txIns)

  queryProtocolParameters :: MonadBlockchainWaitingT m (BundledProtocolParameters BabbageEra)
queryProtocolParameters = forall (m :: * -> *) a.
ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a
-> MonadBlockchainWaitingT m a
MonadBlockchainWaitingT forall (m :: * -> *).
MonadBlockchain m =>
m (BundledProtocolParameters BabbageEra)
queryProtocolParameters

  queryStakePools :: MonadBlockchainWaitingT m (Set PoolId)
queryStakePools = forall (m :: * -> *) a.
ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a
-> MonadBlockchainWaitingT m a
MonadBlockchainWaitingT forall (m :: * -> *). MonadBlockchain m => m (Set PoolId)
queryStakePools

  querySystemStart :: MonadBlockchainWaitingT m SystemStart
querySystemStart = forall (m :: * -> *) a.
ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a
-> MonadBlockchainWaitingT m a
MonadBlockchainWaitingT forall (m :: * -> *). MonadBlockchain m => m SystemStart
querySystemStart

  queryEraHistory :: MonadBlockchainWaitingT m (EraHistory CardanoMode)
queryEraHistory = forall (m :: * -> *) a.
ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a
-> MonadBlockchainWaitingT m a
MonadBlockchainWaitingT forall (m :: * -> *).
MonadBlockchain m =>
m (EraHistory CardanoMode)
queryEraHistory

  querySlotNo :: MonadBlockchainWaitingT m (SlotNo, SlotLength, UTCTime)
querySlotNo = forall (m :: * -> *) a.
ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a
-> MonadBlockchainWaitingT m a
MonadBlockchainWaitingT forall (m :: * -> *).
MonadBlockchain m =>
m (SlotNo, SlotLength, UTCTime)
querySlotNo

  networkId :: MonadBlockchainWaitingT m NetworkId
networkId = forall (m :: * -> *) a.
ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a
-> MonadBlockchainWaitingT m a
MonadBlockchainWaitingT forall (m :: * -> *). MonadBlockchain m => m NetworkId
networkId