module Hydra.Chain.Blockfrost where

import Hydra.Prelude

import Blockfrost.Client qualified as BlockfrostAPI
import Control.Concurrent.Class.MonadSTM (putTMVar, readTQueue, readTVarIO, takeTMVar, writeTQueue, writeTVar)
import Control.Exception (IOException)
import Control.Monad.Catch (Handler (Handler))
import Control.Monad.Catch qualified as Catch
import Control.Retry (RetryPolicyM, RetryStatus (..), constantDelay, recovering, retrying)
import Data.ByteString.Base16 qualified as Base16
import Data.Text qualified as T
import Hydra.Cardano.Api (
  BlockHeader (..),
  ChainPoint (..),
  Hash,
  NetworkId,
  SlotNo (..),
  Tx,
  deserialiseFromCBOR,
  getTxBody,
  getTxId,
  proxyToAsType,
  serialiseToRawBytes,
 )
import Hydra.Chain (ChainComponent, ChainStateHistory, PostTxError (..), prefixOf)
import Hydra.Chain.Backend (ChainBackend (..))
import Hydra.Chain.Blockfrost.Client (APIBlockfrostError (..), blockfrostRetryPolicy, isRetryable, submissionRetryPolicy)
import Hydra.Chain.Blockfrost.Client qualified as Blockfrost
import Hydra.Chain.CardanoClient qualified as CardanoClient
import Hydra.Chain.Direct.Handlers (
  CardanoChainLog (..),
  ChainSyncHandler (..),
  chainSyncHandler,
  mkChain,
  newLocalChainState,
 )
import Hydra.Chain.Direct.State (ChainContext)
import Hydra.Chain.Direct.TimeHandle (newCachedTimeHandle, queryTimeHandle)
import Hydra.Chain.Direct.Wallet (TinyWallet (..))
import Hydra.Logging (Tracer, traceWith)
import Hydra.Options (BlockfrostOptions (..), CardanoChainConfig (..))

newtype BlockfrostBackend a = BlockfrostBackend (ReaderT BlockfrostEnv IO a)
  deriving newtype
    ( (forall a b.
 (a -> b) -> BlockfrostBackend a -> BlockfrostBackend b)
-> (forall a b. a -> BlockfrostBackend b -> BlockfrostBackend a)
-> Functor BlockfrostBackend
forall a b. a -> BlockfrostBackend b -> BlockfrostBackend a
forall a b. (a -> b) -> BlockfrostBackend a -> BlockfrostBackend 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) -> BlockfrostBackend a -> BlockfrostBackend b
fmap :: forall a b. (a -> b) -> BlockfrostBackend a -> BlockfrostBackend b
$c<$ :: forall a b. a -> BlockfrostBackend b -> BlockfrostBackend a
<$ :: forall a b. a -> BlockfrostBackend b -> BlockfrostBackend a
Functor
    , Functor BlockfrostBackend
Functor BlockfrostBackend =>
(forall a. a -> BlockfrostBackend a)
-> (forall a b.
    BlockfrostBackend (a -> b)
    -> BlockfrostBackend a -> BlockfrostBackend b)
-> (forall a b c.
    (a -> b -> c)
    -> BlockfrostBackend a
    -> BlockfrostBackend b
    -> BlockfrostBackend c)
-> (forall a b.
    BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend b)
-> (forall a b.
    BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend a)
-> Applicative BlockfrostBackend
forall a. a -> BlockfrostBackend a
forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend a
forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend b
forall a b.
BlockfrostBackend (a -> b)
-> BlockfrostBackend a -> BlockfrostBackend b
forall a b c.
(a -> b -> c)
-> BlockfrostBackend a
-> BlockfrostBackend b
-> BlockfrostBackend 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 -> BlockfrostBackend a
pure :: forall a. a -> BlockfrostBackend a
$c<*> :: forall a b.
BlockfrostBackend (a -> b)
-> BlockfrostBackend a -> BlockfrostBackend b
<*> :: forall a b.
BlockfrostBackend (a -> b)
-> BlockfrostBackend a -> BlockfrostBackend b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> BlockfrostBackend a
-> BlockfrostBackend b
-> BlockfrostBackend c
liftA2 :: forall a b c.
(a -> b -> c)
-> BlockfrostBackend a
-> BlockfrostBackend b
-> BlockfrostBackend c
$c*> :: forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend b
*> :: forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend b
$c<* :: forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend a
<* :: forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend a
Applicative
    , Applicative BlockfrostBackend
Applicative BlockfrostBackend =>
(forall a b.
 BlockfrostBackend a
 -> (a -> BlockfrostBackend b) -> BlockfrostBackend b)
-> (forall a b.
    BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend b)
-> (forall a. a -> BlockfrostBackend a)
-> Monad BlockfrostBackend
forall a. a -> BlockfrostBackend a
forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend b
forall a b.
BlockfrostBackend a
-> (a -> BlockfrostBackend b) -> BlockfrostBackend 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.
BlockfrostBackend a
-> (a -> BlockfrostBackend b) -> BlockfrostBackend b
>>= :: forall a b.
BlockfrostBackend a
-> (a -> BlockfrostBackend b) -> BlockfrostBackend b
$c>> :: forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend b
>> :: forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend b
$creturn :: forall a. a -> BlockfrostBackend a
return :: forall a. a -> BlockfrostBackend a
Monad
    , Monad BlockfrostBackend
Monad BlockfrostBackend =>
(forall a. IO a -> BlockfrostBackend a)
-> MonadIO BlockfrostBackend
forall a. IO a -> BlockfrostBackend a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> BlockfrostBackend a
liftIO :: forall a. IO a -> BlockfrostBackend a
MonadIO
    , Monad BlockfrostBackend
Monad BlockfrostBackend =>
(forall e a. Exception e => e -> BlockfrostBackend a)
-> (forall a b c.
    BlockfrostBackend a
    -> (a -> BlockfrostBackend b)
    -> (a -> BlockfrostBackend c)
    -> BlockfrostBackend c)
-> (forall a b c.
    BlockfrostBackend a
    -> BlockfrostBackend b
    -> BlockfrostBackend c
    -> BlockfrostBackend c)
-> (forall a b.
    BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend a)
-> MonadThrow BlockfrostBackend
forall e a. Exception e => e -> BlockfrostBackend a
forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend a
forall a b c.
BlockfrostBackend a
-> BlockfrostBackend b
-> BlockfrostBackend c
-> BlockfrostBackend c
forall a b c.
BlockfrostBackend a
-> (a -> BlockfrostBackend b)
-> (a -> BlockfrostBackend c)
-> BlockfrostBackend 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 -> BlockfrostBackend a
throwIO :: forall e a. Exception e => e -> BlockfrostBackend a
$cbracket :: forall a b c.
BlockfrostBackend a
-> (a -> BlockfrostBackend b)
-> (a -> BlockfrostBackend c)
-> BlockfrostBackend c
bracket :: forall a b c.
BlockfrostBackend a
-> (a -> BlockfrostBackend b)
-> (a -> BlockfrostBackend c)
-> BlockfrostBackend c
$cbracket_ :: forall a b c.
BlockfrostBackend a
-> BlockfrostBackend b
-> BlockfrostBackend c
-> BlockfrostBackend c
bracket_ :: forall a b c.
BlockfrostBackend a
-> BlockfrostBackend b
-> BlockfrostBackend c
-> BlockfrostBackend c
$cfinally :: forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend a
finally :: forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend a
MonadThrow
    , MonadThrow BlockfrostBackend
MonadThrow BlockfrostBackend =>
(forall e a.
 Exception e =>
 BlockfrostBackend a
 -> (e -> BlockfrostBackend a) -> BlockfrostBackend a)
-> (forall e b a.
    Exception e =>
    (e -> Maybe b)
    -> BlockfrostBackend a
    -> (b -> BlockfrostBackend a)
    -> BlockfrostBackend a)
-> (forall e a.
    Exception e =>
    BlockfrostBackend a -> BlockfrostBackend (Either e a))
-> (forall e b a.
    Exception e =>
    (e -> Maybe b)
    -> BlockfrostBackend a -> BlockfrostBackend (Either b a))
-> (forall e a.
    Exception e =>
    (e -> BlockfrostBackend a)
    -> BlockfrostBackend a -> BlockfrostBackend a)
-> (forall e b a.
    Exception e =>
    (e -> Maybe b)
    -> (b -> BlockfrostBackend a)
    -> BlockfrostBackend a
    -> BlockfrostBackend a)
-> (forall a b.
    BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend a)
-> (forall a b c.
    BlockfrostBackend a
    -> (a -> BlockfrostBackend b)
    -> (a -> BlockfrostBackend c)
    -> BlockfrostBackend c)
-> (forall a b c.
    BlockfrostBackend a
    -> (a -> ExitCase b -> BlockfrostBackend c)
    -> (a -> BlockfrostBackend b)
    -> BlockfrostBackend (b, c))
-> MonadCatch BlockfrostBackend
forall e a.
Exception e =>
BlockfrostBackend a -> BlockfrostBackend (Either e a)
forall e a.
Exception e =>
BlockfrostBackend a
-> (e -> BlockfrostBackend a) -> BlockfrostBackend a
forall e a.
Exception e =>
(e -> BlockfrostBackend a)
-> BlockfrostBackend a -> BlockfrostBackend a
forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend a
forall e b a.
Exception e =>
(e -> Maybe b)
-> BlockfrostBackend a -> BlockfrostBackend (Either b a)
forall e b a.
Exception e =>
(e -> Maybe b)
-> BlockfrostBackend a
-> (b -> BlockfrostBackend a)
-> BlockfrostBackend a
forall e b a.
Exception e =>
(e -> Maybe b)
-> (b -> BlockfrostBackend a)
-> BlockfrostBackend a
-> BlockfrostBackend a
forall a b c.
BlockfrostBackend a
-> (a -> BlockfrostBackend b)
-> (a -> BlockfrostBackend c)
-> BlockfrostBackend c
forall a b c.
BlockfrostBackend a
-> (a -> ExitCase b -> BlockfrostBackend c)
-> (a -> BlockfrostBackend b)
-> BlockfrostBackend (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 =>
BlockfrostBackend a
-> (e -> BlockfrostBackend a) -> BlockfrostBackend a
catch :: forall e a.
Exception e =>
BlockfrostBackend a
-> (e -> BlockfrostBackend a) -> BlockfrostBackend a
$ccatchJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> BlockfrostBackend a
-> (b -> BlockfrostBackend a)
-> BlockfrostBackend a
catchJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> BlockfrostBackend a
-> (b -> BlockfrostBackend a)
-> BlockfrostBackend a
$ctry :: forall e a.
Exception e =>
BlockfrostBackend a -> BlockfrostBackend (Either e a)
try :: forall e a.
Exception e =>
BlockfrostBackend a -> BlockfrostBackend (Either e a)
$ctryJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> BlockfrostBackend a -> BlockfrostBackend (Either b a)
tryJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> BlockfrostBackend a -> BlockfrostBackend (Either b a)
$chandle :: forall e a.
Exception e =>
(e -> BlockfrostBackend a)
-> BlockfrostBackend a -> BlockfrostBackend a
handle :: forall e a.
Exception e =>
(e -> BlockfrostBackend a)
-> BlockfrostBackend a -> BlockfrostBackend a
$chandleJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> (b -> BlockfrostBackend a)
-> BlockfrostBackend a
-> BlockfrostBackend a
handleJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> (b -> BlockfrostBackend a)
-> BlockfrostBackend a
-> BlockfrostBackend a
$conException :: forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend a
onException :: forall a b.
BlockfrostBackend a -> BlockfrostBackend b -> BlockfrostBackend a
$cbracketOnError :: forall a b c.
BlockfrostBackend a
-> (a -> BlockfrostBackend b)
-> (a -> BlockfrostBackend c)
-> BlockfrostBackend c
bracketOnError :: forall a b c.
BlockfrostBackend a
-> (a -> BlockfrostBackend b)
-> (a -> BlockfrostBackend c)
-> BlockfrostBackend c
$cgeneralBracket :: forall a b c.
BlockfrostBackend a
-> (a -> ExitCase b -> BlockfrostBackend c)
-> (a -> BlockfrostBackend b)
-> BlockfrostBackend (b, c)
generalBracket :: forall a b c.
BlockfrostBackend a
-> (a -> ExitCase b -> BlockfrostBackend c)
-> (a -> BlockfrostBackend b)
-> BlockfrostBackend (b, c)
MonadCatch
    )

data BlockfrostEnv = BlockfrostEnv
  { BlockfrostEnv -> Project
project :: Blockfrost.Project
  , BlockfrostEnv -> TVar IO (Maybe Genesis)
genesisVar :: TVar IO (Maybe Blockfrost.Genesis)
  }

newBlockfrostEnv :: BlockfrostOptions -> IO BlockfrostEnv
newBlockfrostEnv :: BlockfrostOptions -> IO BlockfrostEnv
newBlockfrostEnv BlockfrostOptions{FilePath
projectPath :: FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath} =
  Project -> TVar (Maybe Genesis) -> BlockfrostEnv
Project -> TVar IO (Maybe Genesis) -> BlockfrostEnv
BlockfrostEnv (Project -> TVar (Maybe Genesis) -> BlockfrostEnv)
-> IO Project -> IO (TVar (Maybe Genesis) -> BlockfrostEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath IO (TVar (Maybe Genesis) -> BlockfrostEnv)
-> IO (TVar (Maybe Genesis)) -> IO BlockfrostEnv
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> Maybe Genesis -> IO (TVar IO (Maybe Genesis))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
FilePath -> a -> m (TVar m a)
newLabelledTVarIO FilePath
"blockfrost-genesis-cache" Maybe Genesis
forall a. Maybe a
Nothing

runBlockfrostBackend :: BlockfrostOptions -> BlockfrostBackend a -> IO a
runBlockfrostBackend :: forall a. BlockfrostOptions -> BlockfrostBackend a -> IO a
runBlockfrostBackend BlockfrostOptions
opts BlockfrostBackend a
action = BlockfrostOptions -> IO BlockfrostEnv
newBlockfrostEnv BlockfrostOptions
opts IO BlockfrostEnv -> (BlockfrostEnv -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (BlockfrostEnv -> BlockfrostBackend a -> IO a
forall a. BlockfrostEnv -> BlockfrostBackend a -> IO a
`runBlockfrostBackendWith` BlockfrostBackend a
action)

runBlockfrostBackendWith :: BlockfrostEnv -> BlockfrostBackend a -> IO a
runBlockfrostBackendWith :: forall a. BlockfrostEnv -> BlockfrostBackend a -> IO a
runBlockfrostBackendWith BlockfrostEnv
env (BlockfrostBackend ReaderT BlockfrostEnv IO a
m) = ReaderT BlockfrostEnv IO a -> BlockfrostEnv -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT BlockfrostEnv IO a
m BlockfrostEnv
env

-- | Return the cached value or run the action once and store its result.
-- Concurrent callers may run the action more than once (last write wins),
-- which is safe for immutable values.
memoizeIO :: TVar IO (Maybe a) -> IO a -> IO a
memoizeIO :: forall a. TVar IO (Maybe a) -> IO a -> IO a
memoizeIO TVar IO (Maybe a)
var IO a
action = do
  Maybe a
memoized <- TVar IO (Maybe a) -> IO (Maybe a)
forall a. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar IO (Maybe a)
var
  case Maybe a
memoized of
    Maybe a
Nothing -> do
      a
result <- IO a
action
      STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar IO (Maybe a) -> Maybe a -> STM IO ()
forall a. TVar IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar IO (Maybe a)
var (a -> Maybe a
forall a. a -> Maybe a
Just a
result)
      a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
    Just a
d -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
d

cachedGenesis :: BlockfrostBackend Blockfrost.Genesis
cachedGenesis :: BlockfrostBackend Genesis
cachedGenesis = ReaderT BlockfrostEnv IO Genesis -> BlockfrostBackend Genesis
forall a. ReaderT BlockfrostEnv IO a -> BlockfrostBackend a
BlockfrostBackend (ReaderT BlockfrostEnv IO Genesis -> BlockfrostBackend Genesis)
-> ReaderT BlockfrostEnv IO Genesis -> BlockfrostBackend Genesis
forall a b. (a -> b) -> a -> b
$ do
  BlockfrostEnv{Project
$sel:project:BlockfrostEnv :: BlockfrostEnv -> Project
project :: Project
project, TVar IO (Maybe Genesis)
$sel:genesisVar:BlockfrostEnv :: BlockfrostEnv -> TVar IO (Maybe Genesis)
genesisVar :: TVar IO (Maybe Genesis)
genesisVar} <- ReaderT BlockfrostEnv IO BlockfrostEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO Genesis -> ReaderT BlockfrostEnv IO Genesis
forall a. IO a -> ReaderT BlockfrostEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Genesis -> ReaderT BlockfrostEnv IO Genesis)
-> IO Genesis -> ReaderT BlockfrostEnv IO Genesis
forall a b. (a -> b) -> a -> b
$ TVar IO (Maybe Genesis) -> IO Genesis -> IO Genesis
forall a. TVar IO (Maybe a) -> IO a -> IO a
memoizeIO TVar IO (Maybe Genesis)
genesisVar (IO Genesis -> IO Genesis) -> IO Genesis -> IO Genesis
forall a b. (a -> b) -> a -> b
$ Project -> BlockfrostClientT IO Genesis -> IO Genesis
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
project BlockfrostClientT IO Genesis
Blockfrost.queryGenesisParameters

instance ChainBackend BlockfrostBackend where
  queryGenesisParameters :: BlockfrostBackend (GenesisParameters ShelleyEra)
queryGenesisParameters = Genesis -> GenesisParameters ShelleyEra
Blockfrost.toCardanoGenesisParameters (Genesis -> GenesisParameters ShelleyEra)
-> BlockfrostBackend Genesis
-> BlockfrostBackend (GenesisParameters ShelleyEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockfrostBackend Genesis
cachedGenesis

  queryScriptRegistry :: [TxId] -> BlockfrostBackend ScriptRegistry
queryScriptRegistry [TxId]
txIds = (NetworkId -> BlockfrostClientT IO ScriptRegistry)
-> BlockfrostBackend ScriptRegistry
forall a.
(NetworkId -> BlockfrostClientT IO a) -> BlockfrostBackend a
withNetworkId ((NetworkId -> BlockfrostClientT IO ScriptRegistry)
 -> BlockfrostBackend ScriptRegistry)
-> (NetworkId -> BlockfrostClientT IO ScriptRegistry)
-> BlockfrostBackend ScriptRegistry
forall a b. (a -> b) -> a -> b
$ \NetworkId
networkId ->
    NetworkId -> [TxId] -> BlockfrostClientT IO ScriptRegistry
Blockfrost.queryScriptRegistry NetworkId
networkId [TxId]
txIds

  queryNetworkId :: BlockfrostBackend NetworkId
queryNetworkId = Integer -> NetworkId
Blockfrost.toCardanoNetworkId (Integer -> NetworkId)
-> (Genesis -> Integer) -> Genesis -> NetworkId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Genesis -> Integer
Blockfrost._genesisNetworkMagic (Genesis -> NetworkId)
-> BlockfrostBackend Genesis -> BlockfrostBackend NetworkId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockfrostBackend Genesis
cachedGenesis

  queryTip :: BlockfrostBackend ChainPoint
queryTip = BlockfrostClientT IO ChainPoint -> BlockfrostBackend ChainPoint
forall a. BlockfrostClientT IO a -> BlockfrostBackend a
runQuery BlockfrostClientT IO ChainPoint
Blockfrost.queryTip

  queryUTxO :: [Address ShelleyAddr] -> BlockfrostBackend UTxO
queryUTxO [Address ShelleyAddr]
addresses = (NetworkId -> BlockfrostClientT IO UTxO) -> BlockfrostBackend UTxO
forall a.
(NetworkId -> BlockfrostClientT IO a) -> BlockfrostBackend a
withNetworkId ((NetworkId -> BlockfrostClientT IO UTxO)
 -> BlockfrostBackend UTxO)
-> (NetworkId -> BlockfrostClientT IO UTxO)
-> BlockfrostBackend UTxO
forall a b. (a -> b) -> a -> b
$ \NetworkId
networkId ->
    NetworkId -> [Address ShelleyAddr] -> BlockfrostClientT IO UTxO
Blockfrost.queryUTxO NetworkId
networkId [Address ShelleyAddr]
addresses

  queryUTxOByTxIn :: [TxIn] -> BlockfrostBackend UTxO
queryUTxOByTxIn [TxIn]
txins = (NetworkId -> BlockfrostClientT IO UTxO) -> BlockfrostBackend UTxO
forall a.
(NetworkId -> BlockfrostClientT IO a) -> BlockfrostBackend a
withNetworkId ((NetworkId -> BlockfrostClientT IO UTxO)
 -> BlockfrostBackend UTxO)
-> (NetworkId -> BlockfrostClientT IO UTxO)
-> BlockfrostBackend UTxO
forall a b. (a -> b) -> a -> b
$ \NetworkId
networkId ->
    NetworkId -> [TxIn] -> BlockfrostClientT IO UTxO
Blockfrost.queryUTxOByTxIn NetworkId
networkId [TxIn]
txins

  queryEraHistory :: QueryPoint -> BlockfrostBackend EraHistory
queryEraHistory QueryPoint
_ = BlockfrostClientT IO EraHistory -> BlockfrostBackend EraHistory
forall a. BlockfrostClientT IO a -> BlockfrostBackend a
runQuery BlockfrostClientT IO EraHistory
Blockfrost.queryEraHistory

  querySystemStart :: QueryPoint -> BlockfrostBackend SystemStart
querySystemStart QueryPoint
_ = Genesis -> SystemStart
Blockfrost.toCardanoSystemStart (Genesis -> SystemStart)
-> BlockfrostBackend Genesis -> BlockfrostBackend SystemStart
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockfrostBackend Genesis
cachedGenesis

  queryProtocolParameters :: QueryPoint -> BlockfrostBackend (PParams LedgerEra)
queryProtocolParameters QueryPoint
_ = BlockfrostClientT IO (PParams ConwayEra)
-> BlockfrostBackend (PParams ConwayEra)
forall a. BlockfrostClientT IO a -> BlockfrostBackend a
runQuery BlockfrostClientT IO (PParams ConwayEra)
BlockfrostClientT IO (PParams LedgerEra)
forall (m :: * -> *).
MonadIO m =>
BlockfrostClientT m (PParams LedgerEra)
Blockfrost.queryProtocolParameters

  queryStakePools :: QueryPoint -> BlockfrostBackend (Set PoolId)
queryStakePools QueryPoint
_ = BlockfrostClientT IO (Set PoolId) -> BlockfrostBackend (Set PoolId)
forall a. BlockfrostClientT IO a -> BlockfrostBackend a
runQuery BlockfrostClientT IO (Set PoolId)
Blockfrost.queryStakePools

  queryUTxOFor :: QueryPoint -> VerificationKey PaymentKey -> BlockfrostBackend UTxO
queryUTxOFor QueryPoint
_ VerificationKey PaymentKey
vk = (NetworkId -> BlockfrostClientT IO UTxO) -> BlockfrostBackend UTxO
forall a.
(NetworkId -> BlockfrostClientT IO a) -> BlockfrostBackend a
withNetworkId ((NetworkId -> BlockfrostClientT IO UTxO)
 -> BlockfrostBackend UTxO)
-> (NetworkId -> BlockfrostClientT IO UTxO)
-> BlockfrostBackend UTxO
forall a b. (a -> b) -> a -> b
$ \NetworkId
networkId ->
    NetworkId
-> VerificationKey PaymentKey -> BlockfrostClientT IO UTxO
Blockfrost.queryUTxOFor NetworkId
networkId VerificationKey PaymentKey
vk

  submitTransaction :: Tx -> BlockfrostBackend ()
submitTransaction Tx
tx = BlockfrostBackend TxHash -> BlockfrostBackend ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (BlockfrostBackend TxHash -> BlockfrostBackend ())
-> (BlockfrostClientT IO TxHash -> BlockfrostBackend TxHash)
-> BlockfrostClientT IO TxHash
-> BlockfrostBackend ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockfrostClientT IO TxHash -> BlockfrostBackend TxHash
forall a. BlockfrostClientT IO a -> BlockfrostBackend a
runQuery (BlockfrostClientT IO TxHash -> BlockfrostBackend ())
-> BlockfrostClientT IO TxHash -> BlockfrostBackend ()
forall a b. (a -> b) -> a -> b
$ Tx -> BlockfrostClientT IO TxHash
forall (m :: * -> *). MonadIO m => Tx -> BlockfrostClientT m TxHash
Blockfrost.submitTransaction Tx
tx

  awaitTransaction :: Tx -> VerificationKey PaymentKey -> BlockfrostBackend UTxO
awaitTransaction Tx
tx VerificationKey PaymentKey
vk = (NetworkId -> BlockfrostClientT IO UTxO) -> BlockfrostBackend UTxO
forall a.
(NetworkId -> BlockfrostClientT IO a) -> BlockfrostBackend a
withNetworkId ((NetworkId -> BlockfrostClientT IO UTxO)
 -> BlockfrostBackend UTxO)
-> (NetworkId -> BlockfrostClientT IO UTxO)
-> BlockfrostBackend UTxO
forall a b. (a -> b) -> a -> b
$ \NetworkId
networkId ->
    NetworkId
-> Tx -> VerificationKey PaymentKey -> BlockfrostClientT IO UTxO
Blockfrost.awaitTransaction NetworkId
networkId Tx
tx VerificationKey PaymentKey
vk

  getBlockTime :: BlockfrostBackend NominalDiffTime
getBlockTime = do
    Blockfrost.Genesis{Rational
_genesisActiveSlotsCoefficient :: Rational
$sel:_genesisActiveSlotsCoefficient:Genesis :: Genesis -> Rational
_genesisActiveSlotsCoefficient, Integer
_genesisSlotLength :: Integer
$sel:_genesisSlotLength:Genesis :: Genesis -> Integer
_genesisSlotLength} <- BlockfrostBackend Genesis
cachedGenesis
    NominalDiffTime -> BlockfrostBackend NominalDiffTime
forall a. a -> BlockfrostBackend a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NominalDiffTime -> BlockfrostBackend NominalDiffTime)
-> NominalDiffTime -> BlockfrostBackend NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Rational -> NominalDiffTime
CardanoClient.computeBlockTime (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger Integer
_genesisSlotLength) Rational
_genesisActiveSlotsCoefficient

-- | Run a Blockfrost client action with the backend's project.
runQuery :: Blockfrost.BlockfrostClientT IO a -> BlockfrostBackend a
runQuery :: forall a. BlockfrostClientT IO a -> BlockfrostBackend a
runQuery BlockfrostClientT IO a
action = ReaderT BlockfrostEnv IO a -> BlockfrostBackend a
forall a. ReaderT BlockfrostEnv IO a -> BlockfrostBackend a
BlockfrostBackend (ReaderT BlockfrostEnv IO a -> BlockfrostBackend a)
-> ReaderT BlockfrostEnv IO a -> BlockfrostBackend a
forall a b. (a -> b) -> a -> b
$ do
  BlockfrostEnv{Project
$sel:project:BlockfrostEnv :: BlockfrostEnv -> Project
project :: Project
project} <- ReaderT BlockfrostEnv IO BlockfrostEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO a -> ReaderT BlockfrostEnv IO a
forall a. IO a -> ReaderT BlockfrostEnv IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderT BlockfrostEnv IO a)
-> IO a -> ReaderT BlockfrostEnv IO a
forall a b. (a -> b) -> a -> b
$ Project -> BlockfrostClientT IO a -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
project BlockfrostClientT IO a
action

-- | Run a Blockfrost client action that needs the (cached) network id.
withNetworkId :: (NetworkId -> Blockfrost.BlockfrostClientT IO a) -> BlockfrostBackend a
withNetworkId :: forall a.
(NetworkId -> BlockfrostClientT IO a) -> BlockfrostBackend a
withNetworkId NetworkId -> BlockfrostClientT IO a
action = do
  NetworkId
networkId <- BlockfrostBackend NetworkId
forall (m :: * -> *). ChainBackend m => m NetworkId
queryNetworkId
  BlockfrostClientT IO a -> BlockfrostBackend a
forall a. BlockfrostClientT IO a -> BlockfrostBackend a
runQuery (NetworkId -> BlockfrostClientT IO a
action NetworkId
networkId)

withBlockfrostChain ::
  BlockfrostEnv ->
  Tracer IO CardanoChainLog ->
  CardanoChainConfig ->
  ChainContext ->
  TinyWallet IO ->
  -- | Chain state loaded from persistence.
  ChainStateHistory Tx ->
  ChainComponent Tx IO a
withBlockfrostChain :: forall a.
BlockfrostEnv
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> ChainContext
-> TinyWallet IO
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
withBlockfrostChain BlockfrostEnv
env 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 startFromPrefix :: NonEmpty ChainPoint
startFromPrefix =
        -- 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
:| []
            | Bool
otherwise -> NonEmpty ChainPoint
NonEmpty (ChainPointType Tx)
persistedPoints -- TODO: should warn the user about this
          Maybe ChainPoint
_ -> NonEmpty ChainPoint
NonEmpty (ChainPointType Tx)
persistedPoints

  -- Use the tip if we would otherwise start at the genesis (it can't be a good choice).
  NonEmpty ChainPoint
prefix <-
    case NonEmpty ChainPoint -> ChainPoint
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty ChainPoint
startFromPrefix of
      ChainPoint
ChainPointAtGenesis -> BlockfrostEnv -> BlockfrostBackend ChainPoint -> IO ChainPoint
forall a. BlockfrostEnv -> BlockfrostBackend a -> IO a
runBlockfrostBackendWith BlockfrostEnv
env BlockfrostBackend ChainPoint
forall (m :: * -> *). ChainBackend m => m ChainPoint
queryTip IO ChainPoint
-> (ChainPoint -> NonEmpty ChainPoint) -> IO (NonEmpty ChainPoint)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (ChainPoint -> [ChainPoint] -> NonEmpty ChainPoint
forall a. a -> [a] -> NonEmpty a
:| [])
      ChainPoint
_ -> NonEmpty ChainPoint -> IO (NonEmpty ChainPoint)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty ChainPoint
startFromPrefix

  let getTimeHandle :: IO TimeHandle
getTimeHandle = BlockfrostEnv -> BlockfrostBackend TimeHandle -> IO TimeHandle
forall a. BlockfrostEnv -> BlockfrostBackend a -> IO a
runBlockfrostBackendWith BlockfrostEnv
env BlockfrostBackend TimeHandle
forall (m :: * -> *). (ChainBackend m, Monad m) => m TimeHandle
queryTimeHandle
  SlotNo -> IO TimeHandle
cachedTimeHandle <- (forall a. BlockfrostBackend a -> IO a)
-> IO (SlotNo -> IO TimeHandle)
forall (backend :: * -> *).
ChainBackend backend =>
(forall a. backend a -> IO a) -> IO (SlotNo -> IO TimeHandle)
newCachedTimeHandle (BlockfrostEnv -> BlockfrostBackend a -> IO a
forall a. BlockfrostEnv -> BlockfrostBackend a -> IO a
runBlockfrostBackendWith BlockfrostEnv
env)
  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 <- FilePath -> IO (TQueue IO (Tx, TMVar (Maybe (PostTxError Tx))))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
FilePath -> m (TQueue m a)
newLabelledTQueueIO FilePath
"blockfrost-chain-queue"
  let chainHandle :: Chain Tx IO
chainHandle =
        Tracer IO CardanoChainLog
-> IO TimeHandle
-> TinyWallet IO
-> ChainContext
-> LocalChainState IO Tx
-> SubmitTx 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))) -> SubmitTx 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
  let getGenesis :: IO Genesis
getGenesis = IO Genesis -> IO Genesis
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (BlockfrostEnv -> BlockfrostBackend Genesis -> IO Genesis
forall a. BlockfrostEnv -> BlockfrostBackend a -> IO a
runBlockfrostBackendWith BlockfrostEnv
env BlockfrostBackend Genesis
cachedGenesis)
  Either () a
res <-
    (FilePath, IO ()) -> (FilePath, IO a) -> IO (Either () a)
forall (m :: * -> *) a b.
MonadAsync m =>
(FilePath, m a) -> (FilePath, m b) -> m (Either a b)
raceLabelled
      ( FilePath
"blockfrost-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
          Tracer IO CardanoChainLog
-> TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
-> Project
-> IO Genesis
-> NonEmpty ChainPoint
-> ChainSyncHandler IO
-> TinyWallet IO
-> IO ()
forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadCatch m, MonadAsync m, MonadDelay m,
 MonadLabelledSTM m, MonadMask m) =>
Tracer m CardanoChainLog
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> Project
-> m Genesis
-> NonEmpty ChainPoint
-> ChainSyncHandler m
-> TinyWallet m
-> m ()
blockfrostChain Tracer IO CardanoChainLog
tracer TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
queue Project
project IO Genesis
getGenesis NonEmpty ChainPoint
prefix ChainSyncHandler IO
handler TinyWallet IO
wallet
      )
      (FilePath
"blockfrost-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
  BlockfrostEnv{Project
$sel:project:BlockfrostEnv :: BlockfrostEnv -> Project
project :: Project
project} = BlockfrostEnv
env
  CardanoChainConfig{Maybe ChainPoint
startChainFrom :: Maybe ChainPoint
$sel:startChainFrom:CardanoChainConfig :: CardanoChainConfig -> Maybe ChainPoint
startChainFrom} = CardanoChainConfig
config

  submitTx :: TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx))) -> Tx -> IO ()
  submitTx :: TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx))) -> SubmitTx 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 <- FilePath -> STM IO (TMVar IO (Maybe (PostTxError Tx)))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
FilePath -> STM m (TMVar m a)
newLabelledEmptyTMVar FilePath
"blockfrost-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 =
    BlockfrostConnectException -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (BlockfrostConnectException -> IO ())
-> BlockfrostConnectException -> IO ()
forall a b. (a -> b) -> a -> b
$
      BlockfrostConnectException
        { IOException
ioException :: IOException
$sel:ioException:BlockfrostConnectException :: IOException
ioException
        }

newtype BlockfrostConnectException = BlockfrostConnectException
  { BlockfrostConnectException -> IOException
ioException :: IOException
  }
  deriving stock (Int -> BlockfrostConnectException -> ShowS
[BlockfrostConnectException] -> ShowS
BlockfrostConnectException -> FilePath
(Int -> BlockfrostConnectException -> ShowS)
-> (BlockfrostConnectException -> FilePath)
-> ([BlockfrostConnectException] -> ShowS)
-> Show BlockfrostConnectException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockfrostConnectException -> ShowS
showsPrec :: Int -> BlockfrostConnectException -> ShowS
$cshow :: BlockfrostConnectException -> FilePath
show :: BlockfrostConnectException -> FilePath
$cshowList :: [BlockfrostConnectException] -> ShowS
showList :: [BlockfrostConnectException] -> ShowS
Show)

instance Exception BlockfrostConnectException

blockfrostChain ::
  (MonadIO m, MonadFail m, MonadCatch m, MonadAsync m, MonadDelay m, MonadLabelledSTM m, Catch.MonadMask m) =>
  Tracer m CardanoChainLog ->
  TQueue m (Tx, TMVar m (Maybe (PostTxError Tx))) ->
  Blockfrost.Project ->
  m Blockfrost.Genesis ->
  NonEmpty ChainPoint ->
  ChainSyncHandler m ->
  TinyWallet m ->
  m ()
blockfrostChain :: forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadCatch m, MonadAsync m, MonadDelay m,
 MonadLabelledSTM m, MonadMask m) =>
Tracer m CardanoChainLog
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> Project
-> m Genesis
-> NonEmpty ChainPoint
-> ChainSyncHandler m
-> TinyWallet m
-> m ()
blockfrostChain Tracer m CardanoChainLog
tracer TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
queue Project
prj m Genesis
getGenesis NonEmpty ChainPoint
prefix ChainSyncHandler m
handler TinyWallet m
wallet = do
  m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (FilePath, m ()) -> (FilePath, m ()) -> m ()
forall (m :: * -> *) a b.
MonadAsync m =>
(FilePath, m a) -> (FilePath, m b) -> m ()
raceLabelled_
      (FilePath
"blockfrost-chain-follow", Tracer m CardanoChainLog
-> Project
-> m Genesis
-> NonEmpty ChainPoint
-> ChainSyncHandler m
-> TinyWallet m
-> m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadCatch m, MonadDelay m,
 MonadLabelledSTM m, MonadMask m) =>
Tracer m CardanoChainLog
-> Project
-> m Genesis
-> NonEmpty ChainPoint
-> ChainSyncHandler m
-> TinyWallet m
-> m ()
blockfrostChainFollow Tracer m CardanoChainLog
tracer Project
prj m Genesis
getGenesis NonEmpty ChainPoint
prefix ChainSyncHandler m
handler TinyWallet m
wallet)
      (FilePath
"blockfrost-submission", Tracer m CardanoChainLog
-> (Tx -> m (Either Text TxHash))
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> m ()
forall (m :: * -> *).
MonadSTM m =>
Tracer m CardanoChainLog
-> (Tx -> m (Either Text TxHash))
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> m ()
blockfrostSubmissionClient Tracer m CardanoChainLog
tracer (Project -> Tx -> m (Either Text TxHash)
forall (m :: * -> *).
MonadIO m =>
Project -> Tx -> m (Either Text TxHash)
submitViaBlockfrost Project
prj) TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
queue)

blockfrostChainFollow ::
  forall m.
  (MonadIO m, MonadFail m, MonadCatch m, MonadDelay m, MonadLabelledSTM m, Catch.MonadMask m) =>
  Tracer m CardanoChainLog ->
  Blockfrost.Project ->
  m Blockfrost.Genesis ->
  NonEmpty ChainPoint ->
  ChainSyncHandler m ->
  TinyWallet m ->
  m ()
blockfrostChainFollow :: forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadCatch m, MonadDelay m,
 MonadLabelledSTM m, MonadMask m) =>
Tracer m CardanoChainLog
-> Project
-> m Genesis
-> NonEmpty ChainPoint
-> ChainSyncHandler m
-> TinyWallet m
-> m ()
blockfrostChainFollow Tracer m CardanoChainLog
tracer Project
prj m Genesis
getGenesis NonEmpty ChainPoint
prefix ChainSyncHandler m
handler TinyWallet m
wallet = do
  -- Genesis query and start point resolution are wrapped in retry to survive
  -- transient HTTP errors (e.g. 403 rate limiting, connection resets).
  (Double
blockTime, TVar m BlockHash
stateTVar) <-
    Tracer m CardanoChainLog
-> RetryPolicyM m
-> (RetryStatus -> m (Double, TVar m BlockHash))
-> m (Double, TVar m BlockHash)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Tracer m CardanoChainLog
-> RetryPolicyM m -> (RetryStatus -> m a) -> m a
retryOnBlockfrostError Tracer m CardanoChainLog
tracer RetryPolicyM m
forall (m :: * -> *). MonadIO m => RetryPolicyM m
blockfrostRetryPolicy ((RetryStatus -> m (Double, TVar m BlockHash))
 -> m (Double, TVar m BlockHash))
-> (RetryStatus -> m (Double, TVar m BlockHash))
-> m (Double, TVar m BlockHash)
forall a b. (a -> b) -> a -> b
$ \RetryStatus
_ -> do
      Blockfrost.Genesis{Integer
$sel:_genesisSlotLength:Genesis :: Genesis -> Integer
_genesisSlotLength :: Integer
_genesisSlotLength, Rational
$sel:_genesisActiveSlotsCoefficient:Genesis :: Genesis -> Rational
_genesisActiveSlotsCoefficient :: Rational
_genesisActiveSlotsCoefficient} <- m Genesis
getGenesis
      let Double
blockTime :: Double = Integer -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Integer
_genesisSlotLength Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
_genesisActiveSlotsCoefficient
      -- Start from the latest point and fall back to older ones (best effort)
      -- If none of them can be resolved, we fall back to the tip of the chain.
      BlockHash
blockHash <- [ChainPoint] -> m BlockHash
resolvePrefixPoints (NonEmpty ChainPoint -> [ChainPoint]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty ChainPoint
prefix)
      TVar m BlockHash
stateTVar <- FilePath -> BlockHash -> m (TVar m BlockHash)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
FilePath -> a -> m (TVar m a)
newLabelledTVarIO FilePath
"blockfrost-chain-state" BlockHash
blockHash
      (Double, TVar m BlockHash) -> m (Double, TVar m BlockHash)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
blockTime, TVar m BlockHash
stateTVar)

  (APIBlockfrostError -> m ())
-> (() -> m ()) -> Either APIBlockfrostError () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either APIBlockfrostError -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Either APIBlockfrostError () -> m ())
-> m (Either APIBlockfrostError ()) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RetryPolicyM m
-> (RetryStatus -> Either APIBlockfrostError () -> m Bool)
-> (RetryStatus -> m (Either APIBlockfrostError ()))
-> m (Either APIBlockfrostError ())
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying
      (Double -> RetryPolicyM m
retryPolicy Double
blockTime)
      RetryStatus -> Either APIBlockfrostError () -> m Bool
forall x a. x -> Either APIBlockfrostError a -> m Bool
shouldRetry
      ( \RetryStatus
_ -> do
          Double -> TVar m BlockHash -> m (Either APIBlockfrostError ())
pollForNewBlocks Double
blockTime TVar m BlockHash
stateTVar
            m (Either APIBlockfrostError ())
-> (APIBlockfrostError -> m (Either APIBlockfrostError ()))
-> m (Either APIBlockfrostError ())
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(APIBlockfrostError
ex :: APIBlockfrostError) ->
              Either APIBlockfrostError () -> m (Either APIBlockfrostError ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either APIBlockfrostError () -> m (Either APIBlockfrostError ()))
-> Either APIBlockfrostError () -> m (Either APIBlockfrostError ())
forall a b. (a -> b) -> a -> b
$ APIBlockfrostError -> Either APIBlockfrostError ()
forall a b. a -> Either a b
Left APIBlockfrostError
ex
      )
 where
  shouldRetry :: x -> Either APIBlockfrostError a -> m Bool
  shouldRetry :: forall x a. x -> Either APIBlockfrostError a -> m Bool
shouldRetry x
_ = \case
    Right{} -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Left APIBlockfrostError
err -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ APIBlockfrostError -> Bool
isRetryable APIBlockfrostError
err

  retryPolicy :: Double -> RetryPolicyM m
  retryPolicy :: Double -> RetryPolicyM m
retryPolicy Double
blockTime' = Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
blockTime' Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)

  -- Process every already-confirmed successor of the last processed block,
  -- then sleep one block time only once we caught up to the tip. Blocks with
  -- zero confirmations are left for a later iteration: we only ever observe
  -- blocks that have at least one successor.
  pollForNewBlocks :: Double -> TVar m BlockHash -> m (Either APIBlockfrostError ())
pollForNewBlocks Double
blockTime' TVar m BlockHash
stateTVar = do
    BlockHash
current <- TVar m BlockHash -> m BlockHash
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m BlockHash
stateTVar
    [Block]
blocks <-
      Project -> BlockfrostClientT IO [Block] -> m [Block]
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj (BlockfrostClientT IO [Block] -> m [Block])
-> BlockfrostClientT IO [Block] -> m [Block]
forall a b. (a -> b) -> a -> b
$
        Either Integer BlockHash -> Paged -> BlockfrostClientT IO [Block]
forall (m :: * -> *).
MonadBlockfrost m =>
Either Integer BlockHash -> Paged -> m [Block]
BlockfrostAPI.getNextBlocks' (BlockHash -> Either Integer BlockHash
forall a b. b -> Either a b
Right BlockHash
current) (Int -> Int -> Paged
BlockfrostAPI.paged Int
maxBlockBatch Int
1)
    let confirmed :: [Block]
confirmed = (Block -> Bool) -> [Block] -> [Block]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
1) (Integer -> Bool) -> (Block -> Integer) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Integer
Blockfrost._blockConfirmations) [Block]
blocks
    [Block] -> (Block -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Block]
confirmed ((Block -> m ()) -> m ()) -> (Block -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Block
block -> do
      Tracer m CardanoChainLog
-> Project -> ChainSyncHandler m -> TinyWallet m -> Block -> m ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Tracer m CardanoChainLog
-> Project -> ChainSyncHandler m -> TinyWallet m -> Block -> m ()
processBlock Tracer m CardanoChainLog
tracer Project
prj ChainSyncHandler m
handler TinyWallet m
wallet Block
block
      STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar m BlockHash -> BlockHash -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m BlockHash
stateTVar (Block -> BlockHash
Blockfrost._blockHash Block
block)
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Block] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Block]
blocks Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxBlockBatch) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (Double -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
blockTime')
    Double -> TVar m BlockHash -> m (Either APIBlockfrostError ())
pollForNewBlocks Double
blockTime' TVar m BlockHash
stateTVar

  resolvePrefixPoints :: [ChainPoint] -> m Blockfrost.BlockHash
  resolvePrefixPoints :: [ChainPoint] -> m BlockHash
resolvePrefixPoints = \case
    [] -> m BlockHash
resolveTip
    ChainPoint
cp : [ChainPoint]
cps -> do
      Either SomeException BlockHash
res <- m BlockHash -> m (Either SomeException BlockHash)
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (ChainPoint -> m BlockHash
resolveChainPoint ChainPoint
cp)
      case Either SomeException BlockHash
res of
        Right BlockHash
bh -> BlockHash -> m BlockHash
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockHash
bh
        Left (SomeException
_ :: SomeException) -> [ChainPoint] -> m BlockHash
resolvePrefixPoints [ChainPoint]
cps

  resolveTip :: m Blockfrost.BlockHash
  resolveTip :: m BlockHash
resolveTip = do
    (ChainPoint SlotNo
_ Hash BlockHeader
headerHash) <- Project -> BlockfrostClientT IO ChainPoint -> m ChainPoint
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj BlockfrostClientT IO ChainPoint
Blockfrost.queryTip
    BlockHash -> m BlockHash
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockHash -> m BlockHash) -> BlockHash -> m BlockHash
forall a b. (a -> b) -> a -> b
$ Text -> BlockHash
Blockfrost.BlockHash (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text)
-> (Hash BlockHeader -> ByteString) -> Hash BlockHeader -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> ByteString)
-> (Hash BlockHeader -> ByteString)
-> Hash BlockHeader
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash BlockHeader -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes (Hash BlockHeader -> Text) -> Hash BlockHeader -> Text
forall a b. (a -> b) -> a -> b
$ Hash BlockHeader
headerHash)

  resolveChainPoint :: ChainPoint -> m Blockfrost.BlockHash
  resolveChainPoint :: ChainPoint -> m BlockHash
resolveChainPoint = \case
    ChainPoint
ChainPointAtGenesis -> do
      Either IOException (Either BlockfrostError Block)
result <- IO (Either IOException (Either BlockfrostError Block))
-> m (Either IOException (Either BlockfrostError Block))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException (Either BlockfrostError Block))
 -> m (Either IOException (Either BlockfrostError Block)))
-> IO (Either IOException (Either BlockfrostError Block))
-> m (Either IOException (Either BlockfrostError Block))
forall a b. (a -> b) -> a -> b
$ IO (Either BlockfrostError Block)
-> IO (Either IOException (Either BlockfrostError Block))
forall e (m :: * -> *) a. MonadError e m => m a -> m (Either e a)
Blockfrost.tryError (IO (Either BlockfrostError Block)
 -> IO (Either IOException (Either BlockfrostError Block)))
-> IO (Either BlockfrostError Block)
-> IO (Either IOException (Either BlockfrostError Block))
forall a b. (a -> b) -> a -> b
$ Project
-> BlockfrostClientT IO Block -> IO (Either BlockfrostError Block)
forall a.
Project -> BlockfrostClientT IO a -> IO (Either BlockfrostError a)
Blockfrost.runBlockfrost Project
prj (Either Integer BlockHash -> BlockfrostClientT IO Block
forall (m :: * -> *).
MonadBlockfrost m =>
Either Integer BlockHash -> m Block
Blockfrost.getBlock (Integer -> Either Integer BlockHash
forall a b. a -> Either a b
Left Integer
0))
      case Either IOException (Either BlockfrostError Block)
result of
        Right (Right (Blockfrost.Block{$sel:_blockHash:Block :: Block -> BlockHash
_blockHash = Blockfrost.BlockHash Text
genesisBlockHash})) -> do
          BlockHash -> m BlockHash
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockHash -> m BlockHash) -> BlockHash -> m BlockHash
forall a b. (a -> b) -> a -> b
$ Text -> BlockHash
Blockfrost.BlockHash Text
genesisBlockHash
        Either IOException (Either BlockfrostError Block)
_ -> do
          Blockfrost.Block{$sel:_blockHash:Block :: Block -> BlockHash
_blockHash = Blockfrost.BlockHash Text
block1Hash} <-
            Project -> BlockfrostClientT IO Block -> m Block
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj (Either Integer BlockHash -> BlockfrostClientT IO Block
forall (m :: * -> *).
MonadBlockfrost m =>
Either Integer BlockHash -> m Block
Blockfrost.getBlock (Integer -> Either Integer BlockHash
forall a b. a -> Either a b
Left Integer
1))
          BlockHash -> m BlockHash
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockHash -> m BlockHash) -> BlockHash -> m BlockHash
forall a b. (a -> b) -> a -> b
$ Text -> BlockHash
Blockfrost.BlockHash Text
block1Hash
    ChainPoint SlotNo
_ Hash BlockHeader
headerHash ->
      BlockHash -> m BlockHash
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockHash -> m BlockHash) -> BlockHash -> m BlockHash
forall a b. (a -> b) -> a -> b
$ Text -> BlockHash
Blockfrost.BlockHash (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text)
-> (Hash BlockHeader -> ByteString) -> Hash BlockHeader -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> ByteString)
-> (Hash BlockHeader -> ByteString)
-> Hash BlockHeader
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash BlockHeader -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes (Hash BlockHeader -> Text) -> Hash BlockHeader -> Text
forall a b. (a -> b) -> a -> b
$ Hash BlockHeader
headerHash)

processBlock ::
  (MonadIO m, MonadThrow m) =>
  Tracer m CardanoChainLog ->
  Blockfrost.Project ->
  ChainSyncHandler m ->
  TinyWallet m ->
  Blockfrost.Block ->
  m ()
processBlock :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Tracer m CardanoChainLog
-> Project -> ChainSyncHandler m -> TinyWallet m -> Block -> m ()
processBlock Tracer m CardanoChainLog
tracer Project
prj ChainSyncHandler m
handler TinyWallet m
wallet block :: Block
block@Blockfrost.Block{BlockHash
$sel:_blockHash:Block :: Block -> BlockHash
_blockHash :: BlockHash
_blockHash, Integer
_blockTxCount :: Integer
$sel:_blockTxCount:Block :: Block -> Integer
_blockTxCount, Maybe Integer
_blockHeight :: Maybe Integer
$sel:_blockHeight:Block :: Block -> Maybe Integer
_blockHeight, Maybe Slot
_blockSlot :: Maybe Slot
$sel:_blockSlot:Block :: Block -> Maybe Slot
_blockSlot} = do
  -- A block's transactions are a separate paginated request; the header
  -- already tells us when there is nothing to fetch.
  [Tx]
receivedTxs <-
    if Integer
_blockTxCount Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
      then [Tx] -> m [Tx]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      else do
        [TxHashCBOR]
txHashesCBOR <-
          Project -> BlockfrostClientT IO [TxHashCBOR] -> m [TxHashCBOR]
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj (BlockfrostClientT IO [TxHashCBOR] -> m [TxHashCBOR])
-> ((Paged -> BlockfrostClientT IO [TxHashCBOR])
    -> BlockfrostClientT IO [TxHashCBOR])
-> (Paged -> BlockfrostClientT IO [TxHashCBOR])
-> m [TxHashCBOR]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Paged -> BlockfrostClientT IO [TxHashCBOR])
-> BlockfrostClientT IO [TxHashCBOR]
forall (m :: * -> *) a. Monad m => (Paged -> m [a]) -> m [a]
Blockfrost.allPages ((Paged -> BlockfrostClientT IO [TxHashCBOR]) -> m [TxHashCBOR])
-> (Paged -> BlockfrostClientT IO [TxHashCBOR]) -> m [TxHashCBOR]
forall a b. (a -> b) -> a -> b
$ \Paged
p ->
            Either Integer BlockHash
-> Paged -> SortOrder -> BlockfrostClientT IO [TxHashCBOR]
forall (m :: * -> *).
MonadBlockfrost m =>
Either Integer BlockHash -> Paged -> SortOrder -> m [TxHashCBOR]
Blockfrost.getBlockTxsCBOR' (BlockHash -> Either Integer BlockHash
forall a b. b -> Either a b
Right BlockHash
_blockHash) Paged
p SortOrder
forall a. Default a => a
Blockfrost.def
        (TxHashCBOR -> m Tx) -> [TxHashCBOR] -> m [Tx]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TransactionCBOR -> m Tx
forall (m :: * -> *). MonadThrow m => TransactionCBOR -> m Tx
toTx (TransactionCBOR -> m Tx)
-> (TxHashCBOR -> TransactionCBOR) -> TxHashCBOR -> m Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Blockfrost.TxHashCBOR (TxHash
_txHash, TransactionCBOR
cbor)) -> TransactionCBOR
cbor)) [TxHashCBOR]
txHashesCBOR
  let receivedTxIds :: [TxId]
receivedTxIds = TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody Era -> TxId) -> (Tx -> TxBody Era) -> Tx -> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody (Tx -> TxId) -> [Tx] -> [TxId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx]
receivedTxs
  let point :: ChainPoint
point = Block -> ChainPoint
toChainPoint Block
block
  Tracer m CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
tracer RolledForward{ChainPoint
point :: ChainPoint
$sel:point:ToPost :: ChainPoint
point, [TxId]
receivedTxIds :: [TxId]
$sel:receivedTxIds:ToPost :: [TxId]
receivedTxIds}

  BlockNo
blockNo <- m BlockNo -> (Integer -> m BlockNo) -> Maybe Integer -> m BlockNo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (APIBlockfrostError -> m BlockNo
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (APIBlockfrostError -> m BlockNo)
-> APIBlockfrostError -> m BlockNo
forall a b. (a -> b) -> a -> b
$ BlockHash -> APIBlockfrostError
MissingBlockNo BlockHash
_blockHash) (BlockNo -> m BlockNo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockNo -> m BlockNo)
-> (Integer -> BlockNo) -> Integer -> m BlockNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BlockNo
forall a. Num a => Integer -> a
fromInteger) Maybe Integer
_blockHeight
  Word64
blockSlot <- m Word64 -> (Slot -> m Word64) -> Maybe Slot -> m Word64
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (APIBlockfrostError -> m Word64
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (APIBlockfrostError -> m Word64) -> APIBlockfrostError -> m Word64
forall a b. (a -> b) -> a -> b
$ Maybe Slot -> APIBlockfrostError
MissingBlockSlot Maybe Slot
_blockSlot) (Word64 -> m Word64
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> m Word64) -> (Slot -> Word64) -> Slot -> m Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Word64) -> (Slot -> Integer) -> Slot -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Slot -> Integer
Blockfrost.unSlot) Maybe Slot
_blockSlot
  let Blockfrost.BlockHash Text
blockHashText = BlockHash
_blockHash
  let header :: BlockHeader
header = SlotNo -> Hash BlockHeader -> BlockNo -> BlockHeader
BlockHeader (Word64 -> SlotNo
SlotNo Word64
blockSlot) (FilePath -> Hash BlockHeader
forall a. IsString a => FilePath -> a
fromString (FilePath -> Hash BlockHeader) -> FilePath -> Hash BlockHeader
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
blockHashText) BlockNo
blockNo
  TinyWallet m -> BlockHeader -> [Tx] -> m ()
forall (m :: * -> *). TinyWallet m -> BlockHeader -> [Tx] -> m ()
update TinyWallet m
wallet BlockHeader
header [Tx]
receivedTxs
  ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward ChainSyncHandler m
handler BlockHeader
header [Tx]
receivedTxs

blockfrostSubmissionClient ::
  forall m.
  MonadSTM m =>
  Tracer m CardanoChainLog ->
  -- | How to submit a transaction, yielding a rendered failure reason or the
  -- transaction hash. Must not throw.
  (Tx -> m (Either Text Blockfrost.TxHash)) ->
  TQueue m (Tx, TMVar m (Maybe (PostTxError Tx))) ->
  m ()
blockfrostSubmissionClient :: forall (m :: * -> *).
MonadSTM m =>
Tracer m CardanoChainLog
-> (Tx -> m (Either Text TxHash))
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> m ()
blockfrostSubmissionClient Tracer m CardanoChainLog
tracer Tx -> m (Either Text TxHash)
submit TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
queue = m ()
bfClient
 where
  bfClient :: m ()
bfClient = 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 Era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody Era -> TxId) -> TxBody Era -> TxId
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
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}
    Either Text TxHash
res <- Tx -> m (Either Text TxHash)
submit Tx
tx
    case Either Text TxHash
res of
      Left Text
err -> do
        let postTxError :: PostTxError Tx
postTxError = FailedToPostTx{$sel:failureReason:NoSeedInput :: Text
failureReason = Text
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}
        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))
      Right TxHash
_ -> 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 ()
bfClient

-- | Submit a transaction via Blockfrost, rendering both transport and API
-- level failures into a reason.
submitViaBlockfrost :: MonadIO m => Blockfrost.Project -> Tx -> m (Either Text Blockfrost.TxHash)
submitViaBlockfrost :: forall (m :: * -> *).
MonadIO m =>
Project -> Tx -> m (Either Text TxHash)
submitViaBlockfrost Project
prj Tx
tx =
  IO (Either Text TxHash) -> m (Either Text TxHash)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text TxHash) -> m (Either Text TxHash))
-> IO (Either Text TxHash) -> m (Either Text TxHash)
forall a b. (a -> b) -> a -> b
$
    (TxHash -> Either Text TxHash
forall a b. b -> Either a b
Right (TxHash -> Either Text TxHash)
-> IO TxHash -> IO (Either Text TxHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RetryPolicyM IO
-> Project -> BlockfrostClientT IO TxHash -> IO TxHash
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
RetryPolicyM m -> Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostMWith RetryPolicyM IO
forall (m :: * -> *). MonadIO m => RetryPolicyM m
submissionRetryPolicy Project
prj (Tx -> BlockfrostClientT IO TxHash
forall (m :: * -> *). MonadIO m => Tx -> BlockfrostClientT m TxHash
Blockfrost.submitTransaction Tx
tx))
      IO (Either Text TxHash)
-> (APIBlockfrostError -> IO (Either Text TxHash))
-> IO (Either Text TxHash)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(APIBlockfrostError
e :: APIBlockfrostError) -> Either Text TxHash -> IO (Either Text TxHash)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text TxHash -> IO (Either Text TxHash))
-> (Text -> Either Text TxHash) -> Text -> IO (Either Text TxHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text TxHash
forall a b. a -> Either a b
Left (Text -> IO (Either Text TxHash))
-> Text -> IO (Either Text TxHash)
forall a b. (a -> b) -> a -> b
$ APIBlockfrostError -> Text
forall b a. (Show a, IsString b) => a -> b
show APIBlockfrostError
e)
      IO (Either Text TxHash)
-> (IOException -> IO (Either Text TxHash))
-> IO (Either Text TxHash)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(IOException
e :: IOException) -> Either Text TxHash -> IO (Either Text TxHash)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text TxHash -> IO (Either Text TxHash))
-> (Text -> Either Text TxHash) -> Text -> IO (Either Text TxHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text TxHash
forall a b. a -> Either a b
Left (Text -> IO (Either Text TxHash))
-> Text -> IO (Either Text TxHash)
forall a b. (a -> b) -> a -> b
$ IOException -> Text
forall b a. (Show a, IsString b) => a -> b
show IOException
e)

toChainPoint :: Blockfrost.Block -> ChainPoint
toChainPoint :: Block -> ChainPoint
toChainPoint Blockfrost.Block{Maybe Slot
$sel:_blockSlot:Block :: Block -> Maybe Slot
_blockSlot :: Maybe Slot
_blockSlot, BlockHash
$sel:_blockHash:Block :: Block -> BlockHash
_blockHash :: BlockHash
_blockHash} =
  SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint SlotNo
slotNo Hash BlockHeader
headerHash
 where
  slotNo :: SlotNo
  slotNo :: SlotNo
slotNo = SlotNo -> (Slot -> SlotNo) -> Maybe Slot -> SlotNo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SlotNo
0 (Integer -> SlotNo
forall a. Num a => Integer -> a
fromInteger (Integer -> SlotNo) -> (Slot -> Integer) -> Slot -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Slot -> Integer
Blockfrost.unSlot) Maybe Slot
_blockSlot

  headerHash :: Hash BlockHeader
  headerHash :: Hash BlockHeader
headerHash = FilePath -> Hash BlockHeader
forall a. IsString a => FilePath -> a
fromString (FilePath -> Hash BlockHeader)
-> (Text -> FilePath) -> Text -> Hash BlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> Hash BlockHeader) -> Text -> Hash BlockHeader
forall a b. (a -> b) -> a -> b
$ BlockHash -> Text
Blockfrost.unBlockHash BlockHash
_blockHash

-- | Maximum number of blocks fetched per poll iteration (the Blockfrost page
-- size limit).
maxBlockBatch :: Int
maxBlockBatch :: Int
maxBlockBatch = Int
100

retryOnBlockfrostError ::
  (MonadIO m, Catch.MonadMask m) =>
  Tracer m CardanoChainLog ->
  RetryPolicyM m ->
  (RetryStatus -> m a) ->
  m a
retryOnBlockfrostError :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Tracer m CardanoChainLog
-> RetryPolicyM m -> (RetryStatus -> m a) -> m a
retryOnBlockfrostError Tracer m CardanoChainLog
tracer RetryPolicyM m
policy =
  RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
recovering
    RetryPolicyM m
policy
    [ \RetryStatus{Int
rsCumulativeDelay :: Int
rsCumulativeDelay :: RetryStatus -> Int
rsCumulativeDelay} -> (APIBlockfrostError -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((APIBlockfrostError -> m Bool) -> Handler m Bool)
-> (APIBlockfrostError -> m Bool) -> Handler m Bool
forall a b. (a -> b) -> a -> b
$ \(APIBlockfrostError
ex :: APIBlockfrostError) -> do
        Tracer m CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
tracer (CardanoChainLog -> m ()) -> CardanoChainLog -> m ()
forall a b. (a -> b) -> a -> b
$ BlockfrostTransientError{$sel:reason:ToPost :: Text
reason = APIBlockfrostError -> Text
forall b a. (Show a, IsString b) => a -> b
show APIBlockfrostError
ex, $sel:retryDelay:ToPost :: Int
retryDelay = Int
rsCumulativeDelay}
        Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (APIBlockfrostError -> Bool
isRetryable APIBlockfrostError
ex)
    ]

-- * Helpers

toTx :: MonadThrow m => Blockfrost.TransactionCBOR -> m Tx
toTx :: forall (m :: * -> *). MonadThrow m => TransactionCBOR -> m Tx
toTx (Blockfrost.TransactionCBOR Text
txCbor) =
  case Text -> Either Text ByteString
forall (f :: * -> *). MonadFail f => Text -> f ByteString
decodeBase16 Text
txCbor of
    Left Text
decodeErr -> APIBlockfrostError -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (APIBlockfrostError -> m Tx)
-> (Text -> APIBlockfrostError) -> Text -> m Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> APIBlockfrostError
DecodeError (Text -> m Tx) -> Text -> m Tx
forall a b. (a -> b) -> a -> b
$ Text
"Bad Base16 Tx CBOR: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
decodeErr
    Right ByteString
bytes ->
      case AsType Tx -> ByteString -> Either DecoderError Tx
forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR (Proxy Tx -> AsType Tx
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Tx)) ByteString
bytes of
        Left DecoderError
deserializeErr -> APIBlockfrostError -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (APIBlockfrostError -> m Tx)
-> (Text -> APIBlockfrostError) -> Text -> m Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> APIBlockfrostError
DecodeError (Text -> m Tx) -> Text -> m Tx
forall a b. (a -> b) -> a -> b
$ Text
"Bad Tx CBOR: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DecoderError -> Text
forall b a. (Show a, IsString b) => a -> b
show DecoderError
deserializeErr
        Right Tx
tx -> Tx -> m Tx
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
tx