module Hydra.Chain.Blockfrost where

import Hydra.Prelude

import Control.Concurrent.Class.MonadSTM (newEmptyTMVar, newTQueueIO, newTVarIO, putTMVar, readTQueue, readTVarIO, takeTMVar, writeTQueue, writeTVar)
import Control.Exception (IOException)
import Control.Retry (constantDelay, retrying)
import Data.ByteString.Base16 qualified as Base16
import Data.Text qualified as T
import Hydra.Cardano.Api (
  BlockHeader (..),
  ChainPoint (..),
  Hash,
  SlotNo (..),
  Tx,
  deserialiseFromCBOR,
  getTxBody,
  getTxId,
  proxyToAsType,
  serialiseToRawBytes,
 )
import Hydra.Chain (ChainComponent, ChainStateHistory, PostTxError (..), currentState)
import Hydra.Chain.Backend (ChainBackend (..))
import Hydra.Chain.Blockfrost.Client qualified as Blockfrost
import Hydra.Chain.Direct.Handlers (
  CardanoChainLog (..),
  ChainSyncHandler (..),
  chainSyncHandler,
  mkChain,
  newLocalChainState,
 )
import Hydra.Chain.Direct.State (ChainContext, ChainStateAt (..))
import Hydra.Chain.Direct.TimeHandle (queryTimeHandle)
import Hydra.Chain.Direct.Wallet (TinyWallet (..))
import Hydra.Logging (Tracer, traceWith)
import Hydra.Options (BlockfrostOptions (..), CardanoChainConfig (..))

newtype BlockfrostBackend = BlockfrostBackend {BlockfrostBackend -> BlockfrostOptions
options :: BlockfrostOptions}

instance ChainBackend BlockfrostBackend where
  queryGenesisParameters :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend -> m (GenesisParameters ShelleyEra)
queryGenesisParameters (BlockfrostBackend BlockfrostOptions{FilePath
projectPath :: FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath}) = do
    Project
prj <- IO Project -> m Project
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
    Genesis -> GenesisParameters ShelleyEra
Blockfrost.toCardanoGenesisParameters (Genesis -> GenesisParameters ShelleyEra)
-> m Genesis -> m (GenesisParameters ShelleyEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Project -> BlockfrostClientT IO Genesis -> m Genesis
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj BlockfrostClientT IO Genesis
Blockfrost.queryGenesisParameters

  queryScriptRegistry :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend -> [TxId] -> m ScriptRegistry
queryScriptRegistry (BlockfrostBackend BlockfrostOptions{FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath :: FilePath
projectPath}) [TxId]
txIds = do
    Project
prj <- IO Project -> m Project
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
    Project -> BlockfrostClientT IO ScriptRegistry -> m ScriptRegistry
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj (BlockfrostClientT IO ScriptRegistry -> m ScriptRegistry)
-> BlockfrostClientT IO ScriptRegistry -> m ScriptRegistry
forall a b. (a -> b) -> a -> b
$ [TxId] -> BlockfrostClientT IO ScriptRegistry
Blockfrost.queryScriptRegistry [TxId]
txIds

  queryNetworkId :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend -> m NetworkId
queryNetworkId (BlockfrostBackend BlockfrostOptions{FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath :: FilePath
projectPath}) = do
    Project
prj <- IO Project -> m Project
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
    -- TODO: This calls to queryGenesisParameters again, but we only need the network magic
    Blockfrost.Genesis{Integer
_genesisNetworkMagic :: Integer
$sel:_genesisNetworkMagic:Genesis :: Genesis -> Integer
_genesisNetworkMagic} <- Project -> BlockfrostClientT IO Genesis -> m Genesis
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj BlockfrostClientT IO Genesis
Blockfrost.queryGenesisParameters
    NetworkId -> m NetworkId
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NetworkId -> m NetworkId) -> NetworkId -> m NetworkId
forall a b. (a -> b) -> a -> b
$ Integer -> NetworkId
Blockfrost.toCardanoNetworkId Integer
_genesisNetworkMagic

  queryTip :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend -> m ChainPoint
queryTip (BlockfrostBackend BlockfrostOptions{FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath :: FilePath
projectPath}) = do
    Project
prj <- IO Project -> m Project
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
    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

  queryUTxO :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend -> [Address ShelleyAddr] -> m UTxO
queryUTxO (BlockfrostBackend BlockfrostOptions{FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath :: FilePath
projectPath}) [Address ShelleyAddr]
addresses = do
    Project
prj <- IO Project -> m Project
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
    Blockfrost.Genesis
      { Integer
$sel:_genesisNetworkMagic:Genesis :: Genesis -> Integer
_genesisNetworkMagic :: Integer
_genesisNetworkMagic
      , POSIXTime
_genesisSystemStart :: POSIXTime
$sel:_genesisSystemStart:Genesis :: Genesis -> POSIXTime
_genesisSystemStart
      } <-
      Project -> BlockfrostClientT IO Genesis -> m Genesis
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj BlockfrostClientT IO Genesis
Blockfrost.queryGenesisParameters
    let networkId :: NetworkId
networkId = Integer -> NetworkId
Blockfrost.toCardanoNetworkId Integer
_genesisNetworkMagic
    Project -> BlockfrostClientT IO UTxO -> m UTxO
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj (BlockfrostClientT IO UTxO -> m UTxO)
-> BlockfrostClientT IO UTxO -> m UTxO
forall a b. (a -> b) -> a -> b
$ NetworkId -> [Address ShelleyAddr] -> BlockfrostClientT IO UTxO
Blockfrost.queryUTxO NetworkId
networkId [Address ShelleyAddr]
addresses

  queryEraHistory :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend -> QueryPoint -> m EraHistory
queryEraHistory (BlockfrostBackend BlockfrostOptions{FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath :: FilePath
projectPath}) QueryPoint
_ = do
    Project
prj <- IO Project -> m Project
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
    Project -> BlockfrostClientT IO EraHistory -> m EraHistory
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj BlockfrostClientT IO EraHistory
Blockfrost.queryEraHistory

  querySystemStart :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend -> QueryPoint -> m SystemStart
querySystemStart (BlockfrostBackend BlockfrostOptions{FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath :: FilePath
projectPath}) QueryPoint
_ = do
    Project
prj <- IO Project -> m Project
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
    Project -> BlockfrostClientT IO SystemStart -> m SystemStart
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj BlockfrostClientT IO SystemStart
Blockfrost.querySystemStart

  queryProtocolParameters :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend -> QueryPoint -> m (PParams LedgerEra)
queryProtocolParameters (BlockfrostBackend BlockfrostOptions{FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath :: FilePath
projectPath}) QueryPoint
_ = do
    Project
prj <- IO Project -> m Project
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
    Project
-> BlockfrostClientT IO (PParams ConwayEra)
-> m (PParams ConwayEra)
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj BlockfrostClientT IO (PParams ConwayEra)
BlockfrostClientT IO (PParams LedgerEra)
forall (m :: * -> *).
MonadIO m =>
BlockfrostClientT m (PParams LedgerEra)
Blockfrost.queryProtocolParameters

  queryStakePools :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend -> QueryPoint -> m (Set PoolId)
queryStakePools (BlockfrostBackend BlockfrostOptions{FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath :: FilePath
projectPath}) QueryPoint
_ = do
    Project
prj <- IO Project -> m Project
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
    Project -> BlockfrostClientT IO (Set PoolId) -> m (Set PoolId)
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj BlockfrostClientT IO (Set PoolId)
Blockfrost.queryStakePools

  queryUTxOFor :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend
-> QueryPoint -> VerificationKey PaymentKey -> m UTxO
queryUTxOFor (BlockfrostBackend BlockfrostOptions{FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath :: FilePath
projectPath}) QueryPoint
_ VerificationKey PaymentKey
vk = do
    Project
prj <- IO Project -> m Project
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
    Project -> BlockfrostClientT IO UTxO -> m UTxO
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj (BlockfrostClientT IO UTxO -> m UTxO)
-> BlockfrostClientT IO UTxO -> m UTxO
forall a b. (a -> b) -> a -> b
$ VerificationKey PaymentKey -> BlockfrostClientT IO UTxO
Blockfrost.queryUTxOFor VerificationKey PaymentKey
vk

  submitTransaction :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend -> Tx -> m ()
submitTransaction (BlockfrostBackend BlockfrostOptions{FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath :: FilePath
projectPath}) Tx
tx = do
    Project
prj <- IO Project -> m Project
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
    m TxHash -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m TxHash -> m ()) -> m TxHash -> m ()
forall a b. (a -> b) -> a -> b
$ Project -> BlockfrostClientT IO TxHash -> m TxHash
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj (BlockfrostClientT IO TxHash -> m TxHash)
-> BlockfrostClientT IO TxHash -> m TxHash
forall a b. (a -> b) -> a -> b
$ Tx -> BlockfrostClientT IO TxHash
forall (m :: * -> *). MonadIO m => Tx -> BlockfrostClientT m TxHash
Blockfrost.submitTransaction Tx
tx

  awaitTransaction :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend -> Tx -> m UTxO
awaitTransaction (BlockfrostBackend BlockfrostOptions{FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath :: FilePath
projectPath}) Tx
tx = do
    Project
prj <- IO Project -> m Project
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
    Project -> BlockfrostClientT IO UTxO -> m UTxO
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj (BlockfrostClientT IO UTxO -> m UTxO)
-> BlockfrostClientT IO UTxO -> m UTxO
forall a b. (a -> b) -> a -> b
$ Tx -> BlockfrostClientT IO UTxO
Blockfrost.awaitTransaction Tx
tx

withBlockfrostChain ::
  BlockfrostBackend ->
  Tracer IO CardanoChainLog ->
  CardanoChainConfig ->
  ChainContext ->
  TinyWallet IO ->
  -- | Chain state loaded from persistence.
  ChainStateHistory Tx ->
  ChainComponent Tx IO a
withBlockfrostChain :: forall a.
BlockfrostBackend
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> ChainContext
-> TinyWallet IO
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
withBlockfrostChain BlockfrostBackend
backend Tracer IO CardanoChainLog
tracer CardanoChainConfig
config ChainContext
ctx TinyWallet IO
wallet ChainStateHistory Tx
chainStateHistory ChainCallback Tx IO
callback Chain Tx IO -> IO a
action = do
  -- Last known point on chain as loaded from persistence.
  let persistedPoint :: Maybe ChainPoint
persistedPoint = ChainStateAt -> Maybe ChainPoint
recordedAt (ChainStateHistory Tx -> ChainStateType Tx
forall tx. ChainStateHistory tx -> ChainStateType tx
currentState ChainStateHistory Tx
chainStateHistory)
  TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
queue <- IO (TQueue (Tx, TMVar (Maybe (PostTxError Tx))))
IO (TQueue IO (Tx, TMVar (Maybe (PostTxError Tx))))
forall a. IO (TQueue IO a)
forall (m :: * -> *) a. MonadSTM m => m (TQueue m a)
newTQueueIO
  -- Select a chain point from which to start synchronizing
  ChainPoint
chainPoint <- IO ChainPoint
-> (ChainPoint -> IO ChainPoint)
-> Maybe ChainPoint
-> IO ChainPoint
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BlockfrostBackend -> IO ChainPoint
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> m ChainPoint
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BlockfrostBackend -> m ChainPoint
queryTip BlockfrostBackend
backend) ChainPoint -> IO ChainPoint
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ChainPoint -> IO ChainPoint)
-> Maybe ChainPoint -> IO ChainPoint
forall a b. (a -> b) -> a -> b
$ do
    (ChainPoint -> ChainPoint -> ChainPoint
forall a. Ord a => a -> a -> a
max (ChainPoint -> ChainPoint -> ChainPoint)
-> Maybe ChainPoint -> Maybe (ChainPoint -> ChainPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ChainPoint
startChainFrom Maybe (ChainPoint -> ChainPoint)
-> Maybe ChainPoint -> Maybe ChainPoint
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe ChainPoint
persistedPoint)
      Maybe ChainPoint -> Maybe ChainPoint -> Maybe ChainPoint
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ChainPoint
persistedPoint
      Maybe ChainPoint -> Maybe ChainPoint -> Maybe ChainPoint
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ChainPoint
startChainFrom

  let getTimeHandle :: IO TimeHandle
getTimeHandle = BlockfrostBackend -> IO TimeHandle
forall backend. ChainBackend backend => backend -> IO TimeHandle
queryTimeHandle BlockfrostBackend
backend
  LocalChainState IO Tx
localChainState <- ChainStateHistory Tx -> IO (LocalChainState IO Tx)
forall (m :: * -> *) tx.
(MonadSTM m, IsChainState tx) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState ChainStateHistory Tx
chainStateHistory
  let chainHandle :: Chain Tx IO
chainHandle =
        Tracer IO CardanoChainLog
-> IO TimeHandle
-> TinyWallet IO
-> ChainContext
-> LocalChainState IO Tx
-> 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
forall {m :: * -> *} {a} {a}.
(MonadSTM m, MonadThrow m, Exception a) =>
TQueue m (a, TMVar m (Maybe a)) -> a -> m ()
submitTx TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
queue)

  let handler :: ChainSyncHandler IO
handler = Tracer IO CardanoChainLog
-> ChainCallback Tx IO
-> IO TimeHandle
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m CardanoChainLog
-> ChainCallback Tx m
-> GetTimeHandle m
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler Tracer IO CardanoChainLog
tracer ChainCallback Tx IO
callback IO TimeHandle
getTimeHandle ChainContext
ctx LocalChainState IO Tx
localChainState
  Either () a
res <-
    IO () -> IO a -> IO (Either () a)
forall a b. IO a -> IO b -> IO (Either a b)
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> m b -> m (Either a b)
race
      ( (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle IOException -> IO ()
onIOException (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Project
prj <- FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
          Tracer IO CardanoChainLog
-> TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
-> Project
-> ChainPoint
-> ChainSyncHandler IO
-> TinyWallet IO
-> IO ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadAsync m, MonadDelay m) =>
Tracer m CardanoChainLog
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> Project
-> 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
prj ChainPoint
chainPoint ChainSyncHandler IO
handler TinyWallet IO
wallet
      )
      (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
  BlockfrostBackend{$sel:options:BlockfrostBackend :: BlockfrostBackend -> BlockfrostOptions
options = BlockfrostOptions{FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath :: FilePath
projectPath}} = BlockfrostBackend
backend
  CardanoChainConfig{Maybe ChainPoint
startChainFrom :: Maybe ChainPoint
$sel:startChainFrom:CardanoChainConfig :: CardanoChainConfig -> Maybe ChainPoint
startChainFrom} = CardanoChainConfig
config

  submitTx :: TQueue m (a, TMVar m (Maybe a)) -> a -> m ()
submitTx TQueue m (a, TMVar m (Maybe a))
queue a
tx = do
    TMVar m (Maybe a)
response <- STM m (TMVar m (Maybe a)) -> m (TMVar m (Maybe a))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (TMVar m (Maybe a)) -> m (TMVar m (Maybe a)))
-> STM m (TMVar m (Maybe a)) -> m (TMVar m (Maybe a))
forall a b. (a -> b) -> a -> b
$ do
      TMVar m (Maybe a)
response <- STM m (TMVar m (Maybe a))
forall a. STM m (TMVar m a)
forall (m :: * -> *) a. MonadSTM m => STM m (TMVar m a)
newEmptyTMVar
      TQueue m (a, TMVar m (Maybe a))
-> (a, TMVar m (Maybe a)) -> STM m ()
forall a. TQueue m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue m (a, TMVar m (Maybe a))
queue (a
tx, TMVar m (Maybe a)
response)
      TMVar m (Maybe a) -> STM m (TMVar m (Maybe a))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return TMVar m (Maybe a)
response
    STM m (Maybe a) -> m (Maybe a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TMVar m (Maybe a) -> STM m (Maybe a)
forall a. TMVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
takeTMVar TMVar m (Maybe a)
response)
      m (Maybe a) -> (Maybe a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) a -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO

  onIOException :: IOException -> IO ()
  onIOException :: IOException -> IO ()
onIOException IOException
ioException =
    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, MonadCatch m, MonadAsync m, MonadDelay m) =>
  Tracer m CardanoChainLog ->
  TQueue m (Tx, TMVar m (Maybe (PostTxError Tx))) ->
  Blockfrost.Project ->
  ChainPoint ->
  ChainSyncHandler m ->
  TinyWallet m ->
  m ()
blockfrostChain :: forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadAsync m, MonadDelay m) =>
Tracer m CardanoChainLog
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> Project
-> ChainPoint
-> ChainSyncHandler m
-> TinyWallet m
-> m ()
blockfrostChain Tracer m CardanoChainLog
tracer TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
queue Project
prj ChainPoint
chainPoint 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
$
    m () -> m () -> m ()
forall a b. m a -> m b -> m ()
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m ()
race_
      (Tracer m CardanoChainLog
-> Project
-> ChainPoint
-> ChainSyncHandler m
-> TinyWallet m
-> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadSTM m, MonadDelay m) =>
Tracer m CardanoChainLog
-> Project
-> ChainPoint
-> ChainSyncHandler m
-> TinyWallet m
-> m ()
blockfrostChainFollow Tracer m CardanoChainLog
tracer Project
prj ChainPoint
chainPoint ChainSyncHandler m
handler TinyWallet m
wallet)
      (Project
-> Tracer m CardanoChainLog
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> m ()
forall (m :: * -> *).
(MonadIO m, MonadDelay m, MonadSTM m) =>
Project
-> Tracer m CardanoChainLog
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> m ()
blockfrostSubmissionClient Project
prj Tracer m CardanoChainLog
tracer TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
queue)

blockfrostChainFollow ::
  (MonadIO m, MonadCatch m, MonadSTM m, MonadDelay m) =>
  Tracer m CardanoChainLog ->
  Blockfrost.Project ->
  ChainPoint ->
  ChainSyncHandler m ->
  TinyWallet m ->
  m ()
blockfrostChainFollow :: forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadSTM m, MonadDelay m) =>
Tracer m CardanoChainLog
-> Project
-> ChainPoint
-> ChainSyncHandler m
-> TinyWallet m
-> m ()
blockfrostChainFollow Tracer m CardanoChainLog
tracer Project
prj ChainPoint
chainPoint ChainSyncHandler m
handler TinyWallet m
wallet = do
  Blockfrost.Genesis{Integer
_genesisSlotLength :: Integer
$sel:_genesisSlotLength:Genesis :: Genesis -> Integer
_genesisSlotLength, Rational
_genesisActiveSlotsCoefficient :: Rational
$sel:_genesisActiveSlotsCoefficient:Genesis :: Genesis -> Rational
_genesisActiveSlotsCoefficient} <- Project -> BlockfrostClientT IO Genesis -> m Genesis
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj BlockfrostClientT IO Genesis
forall (m :: * -> *). MonadBlockfrost m => m Genesis
Blockfrost.getLedgerGenesis

  Blockfrost.Block{$sel:_blockHash:Block :: Block -> BlockHash
_blockHash = (Blockfrost.BlockHash Text
genesisBlockHash)} <-
    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
0))

  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

  let blockHash :: BlockHash
blockHash = ChainPoint -> Text -> BlockHash
fromChainPoint ChainPoint
chainPoint Text
genesisBlockHash

  TVar m BlockHash
stateTVar <- BlockHash -> m (TVar m BlockHash)
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO BlockHash
blockHash

  m (Either APIBlockfrostError Any) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Either APIBlockfrostError Any) -> m ())
-> m (Either APIBlockfrostError Any) -> m ()
forall a b. (a -> b) -> a -> b
$
    RetryPolicyM m
-> (RetryStatus -> Either APIBlockfrostError Any -> m Bool)
-> (RetryStatus -> m (Either APIBlockfrostError Any))
-> m (Either APIBlockfrostError Any)
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying (Double -> RetryPolicyM m
forall {m :: * -> *} {a}.
(Monad m, RealFrac a) =>
a -> RetryPolicyM m
retryPolicy Double
blockTime) RetryStatus -> Either APIBlockfrostError Any -> m Bool
forall {f :: * -> *} {p} {b}.
Applicative f =>
p -> Either APIBlockfrostError b -> f Bool
shouldRetry ((RetryStatus -> m (Either APIBlockfrostError Any))
 -> m (Either APIBlockfrostError Any))
-> (RetryStatus -> m (Either APIBlockfrostError Any))
-> m (Either APIBlockfrostError Any)
forall a b. (a -> b) -> a -> b
$ \RetryStatus
_ -> do
      TVar m BlockHash -> m (Either APIBlockfrostError Any)
loop TVar m BlockHash
stateTVar
        m (Either APIBlockfrostError Any)
-> (APIBlockfrostError -> m (Either APIBlockfrostError Any))
-> m (Either APIBlockfrostError Any)
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 Any -> m (Either APIBlockfrostError Any)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either APIBlockfrostError Any
 -> m (Either APIBlockfrostError Any))
-> Either APIBlockfrostError Any
-> m (Either APIBlockfrostError Any)
forall a b. (a -> b) -> a -> b
$ APIBlockfrostError -> Either APIBlockfrostError Any
forall a b. a -> Either a b
Left APIBlockfrostError
ex
 where
  shouldRetry :: p -> Either APIBlockfrostError b -> f Bool
shouldRetry p
_ = \case
    Right{} -> Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Left APIBlockfrostError
err -> Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> f Bool) -> Bool -> f Bool
forall a b. (a -> b) -> a -> b
$ APIBlockfrostError -> Bool
isRetryable APIBlockfrostError
err

  retryPolicy :: a -> RetryPolicyM m
retryPolicy a
blockTime' = Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay (a -> Int
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate a
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)

  loop :: TVar m BlockHash -> m (Either APIBlockfrostError Any)
loop 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
    BlockHash
nextBlockHash <- Tracer m CardanoChainLog
-> Project
-> ChainSyncHandler m
-> TinyWallet m
-> Integer
-> BlockHash
-> m BlockHash
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Tracer m CardanoChainLog
-> Project
-> ChainSyncHandler m
-> TinyWallet m
-> Integer
-> BlockHash
-> m BlockHash
rollForward Tracer m CardanoChainLog
tracer Project
prj ChainSyncHandler m
handler TinyWallet m
wallet Integer
1 BlockHash
current
    DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
    STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (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 BlockHash
nextBlockHash
    TVar m BlockHash -> m (Either APIBlockfrostError Any)
loop TVar m BlockHash
stateTVar

rollForward ::
  (MonadIO m, MonadThrow m) =>
  Tracer m CardanoChainLog ->
  Blockfrost.Project ->
  ChainSyncHandler m ->
  TinyWallet m ->
  Integer ->
  Blockfrost.BlockHash ->
  m Blockfrost.BlockHash
rollForward :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Tracer m CardanoChainLog
-> Project
-> ChainSyncHandler m
-> TinyWallet m
-> Integer
-> BlockHash
-> m BlockHash
rollForward Tracer m CardanoChainLog
tracer Project
prj ChainSyncHandler m
handler TinyWallet m
wallet Integer
blockConfirmations BlockHash
blockHash = do
  block :: Block
block@Blockfrost.Block
    { BlockHash
$sel:_blockHash:Block :: Block -> BlockHash
_blockHash :: BlockHash
_blockHash
    , Integer
_blockConfirmations :: Integer
$sel:_blockConfirmations:Block :: Block -> Integer
_blockConfirmations
    , Maybe BlockHash
_blockNextBlock :: Maybe BlockHash
$sel:_blockNextBlock:Block :: Block -> Maybe BlockHash
_blockNextBlock
    , Maybe Integer
_blockHeight :: Maybe Integer
$sel:_blockHeight:Block :: Block -> Maybe Integer
_blockHeight
    , Maybe Slot
_blockSlot :: Maybe Slot
$sel:_blockSlot:Block :: Block -> Maybe Slot
_blockSlot
    , POSIXTime
_blockTime :: POSIXTime
$sel:_blockTime:Block :: Block -> POSIXTime
_blockTime
    } <-
    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 -> BlockfrostClientT IO Block
forall (m :: * -> *).
MonadBlockfrost m =>
Either Integer BlockHash -> m Block
Blockfrost.getBlock (BlockHash -> Either Integer BlockHash
forall a b. b -> Either a b
Right BlockHash
blockHash)

  -- Check if block within the safe zone to be processes
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
_blockConfirmations Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
blockConfirmations) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    APIBlockfrostError -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (BlockHash -> APIBlockfrostError
NotEnoughBlockConfirmations BlockHash
_blockHash)

  -- Search block transactions
  [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

  -- Check if block contains a reference to its next
  BlockHash
nextBlockHash <- m BlockHash
-> (BlockHash -> m BlockHash) -> Maybe BlockHash -> m BlockHash
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (APIBlockfrostError -> m BlockHash
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (APIBlockfrostError -> m BlockHash)
-> APIBlockfrostError -> m BlockHash
forall a b. (a -> b) -> a -> b
$ BlockHash -> APIBlockfrostError
MissingNextBlockHash BlockHash
_blockHash) BlockHash -> m BlockHash
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlockHash
_blockNextBlock

  -- Convert to cardano-api Tx
  [Tx]
receivedTxs <- (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
  let Blockfrost.BlockHash Text
blockHash' = BlockHash
_blockHash
  let blockHash'' :: Hash BlockHeader
blockHash'' = 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
blockHash'
  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 header :: BlockHeader
header = SlotNo -> Hash BlockHeader -> BlockNo -> BlockHeader
BlockHeader (Word64 -> SlotNo
SlotNo Word64
blockSlot) Hash BlockHeader
blockHash'' BlockNo
blockNo
  -- wallet update
  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

  BlockHash -> m BlockHash
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockHash
nextBlockHash

blockfrostSubmissionClient ::
  forall m.
  (MonadIO m, MonadDelay m, MonadSTM m) =>
  Blockfrost.Project ->
  Tracer m CardanoChainLog ->
  TQueue m (Tx, TMVar m (Maybe (PostTxError Tx))) ->
  m ()
blockfrostSubmissionClient :: forall (m :: * -> *).
(MonadIO m, MonadDelay m, MonadSTM m) =>
Project
-> Tracer m CardanoChainLog
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> m ()
blockfrostSubmissionClient Project
prj Tracer m CardanoChainLog
tracer 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 IOException (Either BlockfrostError TxHash)
res <- IO (Either IOException (Either BlockfrostError TxHash))
-> m (Either IOException (Either BlockfrostError TxHash))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException (Either BlockfrostError TxHash))
 -> m (Either IOException (Either BlockfrostError TxHash)))
-> IO (Either IOException (Either BlockfrostError TxHash))
-> m (Either IOException (Either BlockfrostError TxHash))
forall a b. (a -> b) -> a -> b
$ IO (Either BlockfrostError TxHash)
-> IO (Either IOException (Either BlockfrostError TxHash))
forall e (m :: * -> *) a. MonadError e m => m a -> m (Either e a)
Blockfrost.tryError (IO (Either BlockfrostError TxHash)
 -> IO (Either IOException (Either BlockfrostError TxHash)))
-> IO (Either BlockfrostError TxHash)
-> IO (Either IOException (Either BlockfrostError TxHash))
forall a b. (a -> b) -> a -> b
$ Project
-> BlockfrostClientT IO TxHash
-> IO (Either BlockfrostError TxHash)
forall a.
Project -> BlockfrostClientT IO a -> IO (Either BlockfrostError a)
Blockfrost.runBlockfrost Project
prj (BlockfrostClientT IO TxHash -> IO (Either BlockfrostError TxHash))
-> BlockfrostClientT IO TxHash
-> IO (Either BlockfrostError TxHash)
forall a b. (a -> b) -> a -> b
$ Tx -> BlockfrostClientT IO TxHash
forall (m :: * -> *). MonadIO m => Tx -> BlockfrostClientT m TxHash
Blockfrost.submitTransaction Tx
tx
    case Either IOException (Either BlockfrostError TxHash)
res of
      Left IOException
err -> do
        let postTxError :: PostTxError Tx
postTxError = FailedToPostTx{$sel:failureReason:NoSeedInput :: Text
failureReason = IOException -> Text
forall b a. (Show a, IsString b) => a -> b
show IOException
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}
        DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
        STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TMVar m (Maybe (PostTxError Tx))
-> Maybe (PostTxError Tx) -> STM m ()
forall a. TMVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m ()
putTMVar TMVar m (Maybe (PostTxError Tx))
response (PostTxError Tx -> Maybe (PostTxError Tx)
forall a. a -> Maybe a
Just PostTxError Tx
postTxError))
      Right Either BlockfrostError 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

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

-- * Helpers

data APIBlockfrostError
  = BlockfrostError Text
  | DecodeError Text
  | NotEnoughBlockConfirmations Blockfrost.BlockHash
  | MissingBlockNo Blockfrost.BlockHash
  | MissingBlockSlot (Maybe Blockfrost.Slot)
  | MissingNextBlockHash Blockfrost.BlockHash
  deriving (Int -> APIBlockfrostError -> ShowS
[APIBlockfrostError] -> ShowS
APIBlockfrostError -> FilePath
(Int -> APIBlockfrostError -> ShowS)
-> (APIBlockfrostError -> FilePath)
-> ([APIBlockfrostError] -> ShowS)
-> Show APIBlockfrostError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> APIBlockfrostError -> ShowS
showsPrec :: Int -> APIBlockfrostError -> ShowS
$cshow :: APIBlockfrostError -> FilePath
show :: APIBlockfrostError -> FilePath
$cshowList :: [APIBlockfrostError] -> ShowS
showList :: [APIBlockfrostError] -> ShowS
Show, Show APIBlockfrostError
Typeable APIBlockfrostError
(Typeable APIBlockfrostError, Show APIBlockfrostError) =>
(APIBlockfrostError -> SomeException)
-> (SomeException -> Maybe APIBlockfrostError)
-> (APIBlockfrostError -> FilePath)
-> Exception APIBlockfrostError
SomeException -> Maybe APIBlockfrostError
APIBlockfrostError -> FilePath
APIBlockfrostError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> FilePath) -> Exception e
$ctoException :: APIBlockfrostError -> SomeException
toException :: APIBlockfrostError -> SomeException
$cfromException :: SomeException -> Maybe APIBlockfrostError
fromException :: SomeException -> Maybe APIBlockfrostError
$cdisplayException :: APIBlockfrostError -> FilePath
displayException :: APIBlockfrostError -> FilePath
Exception)

isRetryable :: APIBlockfrostError -> Bool
isRetryable :: APIBlockfrostError -> Bool
isRetryable (BlockfrostError Text
_) = Bool
True
isRetryable (DecodeError Text
_) = Bool
False
isRetryable (NotEnoughBlockConfirmations BlockHash
_) = Bool
True
isRetryable (MissingBlockNo BlockHash
_) = Bool
True
isRetryable (MissingBlockSlot Maybe Slot
_) = Bool
True
isRetryable (MissingNextBlockHash BlockHash
_) = Bool
True

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

fromChainPoint :: ChainPoint -> Text -> Blockfrost.BlockHash
fromChainPoint :: ChainPoint -> Text -> BlockHash
fromChainPoint ChainPoint
chainPoint Text
genesisBlockHash = case ChainPoint
chainPoint of
  ChainPoint SlotNo
_ Hash BlockHeader
headerHash -> 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)
  ChainPoint
ChainPointAtGenesis -> Text -> BlockHash
Blockfrost.BlockHash Text
genesisBlockHash