|
| 1 | +{-# LANGUAGE DuplicateRecordFields #-} |
| 2 | + |
| 3 | +module Hydra.Blockfrost.ChainObserver where |
| 4 | + |
| 5 | +import Hydra.Prelude |
| 6 | + |
| 7 | +import Blockfrost.Client ( |
| 8 | + BlockfrostClientT, |
| 9 | + runBlockfrost, |
| 10 | + ) |
| 11 | +import Blockfrost.Client qualified as Blockfrost |
| 12 | +import Control.Concurrent.Class.MonadSTM ( |
| 13 | + MonadSTM (readTVarIO), |
| 14 | + newTVarIO, |
| 15 | + writeTVar, |
| 16 | + ) |
| 17 | +import Control.Retry (constantDelay, retrying) |
| 18 | +import Data.ByteString.Base16 qualified as Base16 |
| 19 | +import Hydra.Cardano.Api ( |
| 20 | + ChainPoint (..), |
| 21 | + HasTypeProxy (..), |
| 22 | + Hash, |
| 23 | + NetworkId (..), |
| 24 | + NetworkMagic (..), |
| 25 | + SerialiseAsCBOR (..), |
| 26 | + SlotNo (..), |
| 27 | + Tx, |
| 28 | + UTxO, |
| 29 | + serialiseToRawBytes, |
| 30 | + ) |
| 31 | +import Hydra.Cardano.Api.Prelude ( |
| 32 | + BlockHeader (..), |
| 33 | + ) |
| 34 | +import Hydra.Chain.Direct.Handlers (convertObservation) |
| 35 | +import Hydra.ChainObserver.NodeClient ( |
| 36 | + ChainObservation (..), |
| 37 | + ChainObserverLog (..), |
| 38 | + NodeClient (..), |
| 39 | + ObserverHandler, |
| 40 | + logOnChainTx, |
| 41 | + observeAll, |
| 42 | + ) |
| 43 | +import Hydra.Logging (Tracer, traceWith) |
| 44 | +import Hydra.Tx (IsTx (..)) |
| 45 | + |
| 46 | +data APIBlockfrostError |
| 47 | + = BlockfrostError Text |
| 48 | + | DecodeError Text |
| 49 | + | NotEnoughBlockConfirmations Blockfrost.BlockHash |
| 50 | + | MissingBlockNo Blockfrost.BlockHash |
| 51 | + | MissingNextBlockHash Blockfrost.BlockHash |
| 52 | + deriving (Show, Exception) |
| 53 | + |
| 54 | +runBlockfrostM :: |
| 55 | + (MonadIO m, MonadThrow m) => |
| 56 | + Blockfrost.Project -> |
| 57 | + BlockfrostClientT IO a -> |
| 58 | + m a |
| 59 | +runBlockfrostM prj action = do |
| 60 | + result <- liftIO $ runBlockfrost prj action |
| 61 | + case result of |
| 62 | + Left err -> throwIO (BlockfrostError $ show err) |
| 63 | + Right val -> pure val |
| 64 | + |
| 65 | +blockfrostClient :: |
| 66 | + Tracer IO ChainObserverLog -> |
| 67 | + FilePath -> |
| 68 | + Integer -> |
| 69 | + NodeClient IO |
| 70 | +blockfrostClient tracer projectPath blockConfirmations = do |
| 71 | + NodeClient |
| 72 | + { follow = \startChainFrom observerHandler -> do |
| 73 | + prj <- Blockfrost.projectFromFile projectPath |
| 74 | + |
| 75 | + Blockfrost.Block{_blockHash = (Blockfrost.BlockHash genesisBlockHash)} <- |
| 76 | + runBlockfrostM prj (Blockfrost.getBlock (Left 0)) |
| 77 | + |
| 78 | + Blockfrost.Genesis |
| 79 | + { _genesisActiveSlotsCoefficient |
| 80 | + , _genesisSlotLength |
| 81 | + , _genesisNetworkMagic |
| 82 | + } <- |
| 83 | + runBlockfrostM prj Blockfrost.getLedgerGenesis |
| 84 | + |
| 85 | + let networkId = fromNetworkMagic _genesisNetworkMagic |
| 86 | + traceWith tracer ConnectingToExternalNode{networkId} |
| 87 | + |
| 88 | + chainPoint <- |
| 89 | + case startChainFrom of |
| 90 | + Just point -> pure point |
| 91 | + Nothing -> do |
| 92 | + toChainPoint <$> runBlockfrostM prj Blockfrost.getLatestBlock |
| 93 | + |
| 94 | + traceWith tracer StartObservingFrom{chainPoint} |
| 95 | + |
| 96 | + let blockTime = realToFrac _genesisSlotLength / realToFrac _genesisActiveSlotsCoefficient |
| 97 | + |
| 98 | + let blockHash = fromChainPoint chainPoint genesisBlockHash |
| 99 | + |
| 100 | + stateTVar <- newTVarIO (blockHash, mempty) |
| 101 | + void $ |
| 102 | + retrying (retryPolicy blockTime) shouldRetry $ \_ -> do |
| 103 | + loop tracer prj networkId blockTime observerHandler blockConfirmations stateTVar |
| 104 | + `catch` \(ex :: APIBlockfrostError) -> |
| 105 | + pure $ Left ex |
| 106 | + } |
| 107 | + where |
| 108 | + shouldRetry _ = \case |
| 109 | + Right{} -> pure False |
| 110 | + Left err -> pure $ isRetryable err |
| 111 | + |
| 112 | + retryPolicy blockTime = constantDelay (truncate blockTime * 1000 * 1000) |
| 113 | + |
| 114 | +-- | Iterative process that follows the chain using a naive roll-forward approach, |
| 115 | +-- keeping track of the latest known current block and UTxO view. |
| 116 | +-- This process operates at full speed without waiting between calls, |
| 117 | +-- favoring the catch-up process. |
| 118 | +loop :: |
| 119 | + (MonadIO m, MonadThrow m, MonadSTM m) => |
| 120 | + Tracer m ChainObserverLog -> |
| 121 | + Blockfrost.Project -> |
| 122 | + NetworkId -> |
| 123 | + DiffTime -> |
| 124 | + ObserverHandler m -> |
| 125 | + Integer -> |
| 126 | + TVar m (Blockfrost.BlockHash, UTxO) -> |
| 127 | + m a |
| 128 | +loop tracer prj networkId blockTime observerHandler blockConfirmations stateTVar = do |
| 129 | + current <- readTVarIO stateTVar |
| 130 | + next <- rollForward tracer prj networkId observerHandler blockConfirmations current |
| 131 | + atomically $ writeTVar stateTVar next |
| 132 | + loop tracer prj networkId blockTime observerHandler blockConfirmations stateTVar |
| 133 | + |
| 134 | +-- | From the current block and UTxO view, we collect Hydra observations |
| 135 | +-- and yield the next block and adjusted UTxO view. |
| 136 | +rollForward :: |
| 137 | + (MonadIO m, MonadThrow m) => |
| 138 | + Tracer m ChainObserverLog -> |
| 139 | + Blockfrost.Project -> |
| 140 | + NetworkId -> |
| 141 | + ObserverHandler m -> |
| 142 | + Integer -> |
| 143 | + (Blockfrost.BlockHash, UTxO) -> |
| 144 | + m (Blockfrost.BlockHash, UTxO) |
| 145 | +rollForward tracer prj networkId observerHandler blockConfirmations (blockHash, utxo) = do |
| 146 | + block@Blockfrost.Block |
| 147 | + { _blockHash |
| 148 | + , _blockConfirmations |
| 149 | + , _blockNextBlock |
| 150 | + , _blockHeight |
| 151 | + } <- |
| 152 | + runBlockfrostM prj $ Blockfrost.getBlock (Right blockHash) |
| 153 | + |
| 154 | + -- Check if block within the safe zone to be processes |
| 155 | + when (_blockConfirmations < blockConfirmations) $ |
| 156 | + throwIO (NotEnoughBlockConfirmations _blockHash) |
| 157 | + |
| 158 | + -- Check if block contains a reference to its next |
| 159 | + nextBlockHash <- maybe (throwIO $ MissingNextBlockHash _blockHash) pure _blockNextBlock |
| 160 | + |
| 161 | + -- Search block transactions |
| 162 | + txHashes <- runBlockfrostM prj . Blockfrost.allPages $ \p -> |
| 163 | + Blockfrost.getBlockTxs' (Right _blockHash) p Blockfrost.def |
| 164 | + |
| 165 | + -- Collect CBOR representations |
| 166 | + cborTxs <- traverse (runBlockfrostM prj . Blockfrost.getTxCBOR) txHashes |
| 167 | + |
| 168 | + -- Convert to cardano-api Tx |
| 169 | + receivedTxs <- mapM toTx cborTxs |
| 170 | + let receivedTxIds = txId <$> receivedTxs |
| 171 | + let point = toChainPoint block |
| 172 | + traceWith tracer RollForward{point, receivedTxIds} |
| 173 | + |
| 174 | + -- Collect head observations |
| 175 | + let (adjustedUTxO, observations) = observeAll networkId utxo receivedTxs |
| 176 | + let onChainTxs = mapMaybe convertObservation observations |
| 177 | + forM_ onChainTxs (traceWith tracer . logOnChainTx) |
| 178 | + |
| 179 | + blockNo <- maybe (throwIO $ MissingBlockNo _blockHash) (pure . fromInteger) _blockHeight |
| 180 | + let observationsAt = HeadObservation point blockNo <$> onChainTxs |
| 181 | + |
| 182 | + -- Call observer handler |
| 183 | + observerHandler $ |
| 184 | + if null observationsAt |
| 185 | + then [Tick point blockNo] |
| 186 | + else observationsAt |
| 187 | + |
| 188 | + -- Next |
| 189 | + pure (nextBlockHash, adjustedUTxO) |
| 190 | + |
| 191 | +-- * Helpers |
| 192 | + |
| 193 | +isRetryable :: APIBlockfrostError -> Bool |
| 194 | +isRetryable (BlockfrostError _) = True |
| 195 | +isRetryable (DecodeError _) = False |
| 196 | +isRetryable (NotEnoughBlockConfirmations _) = True |
| 197 | +isRetryable (MissingBlockNo _) = True |
| 198 | +isRetryable (MissingNextBlockHash _) = True |
| 199 | + |
| 200 | +toChainPoint :: Blockfrost.Block -> ChainPoint |
| 201 | +toChainPoint Blockfrost.Block{_blockSlot, _blockHash} = |
| 202 | + ChainPoint slotNo headerHash |
| 203 | + where |
| 204 | + slotNo :: SlotNo |
| 205 | + slotNo = maybe 0 (fromInteger . Blockfrost.unSlot) _blockSlot |
| 206 | + |
| 207 | + headerHash :: Hash BlockHeader |
| 208 | + headerHash = fromString . toString $ Blockfrost.unBlockHash _blockHash |
| 209 | + |
| 210 | +fromNetworkMagic :: Integer -> NetworkId |
| 211 | +fromNetworkMagic = \case |
| 212 | + 0 -> Mainnet |
| 213 | + magicNbr -> Testnet (NetworkMagic (fromInteger magicNbr)) |
| 214 | + |
| 215 | +toTx :: MonadThrow m => Blockfrost.TransactionCBOR -> m Tx |
| 216 | +toTx (Blockfrost.TransactionCBOR txCbor) = |
| 217 | + case decodeBase16 txCbor of |
| 218 | + Left decodeErr -> throwIO . DecodeError $ "Bad Base16 Tx CBOR: " <> decodeErr |
| 219 | + Right bytes -> |
| 220 | + case deserialiseFromCBOR (proxyToAsType (Proxy @Tx)) bytes of |
| 221 | + Left deserializeErr -> throwIO . DecodeError $ "Bad Tx CBOR: " <> show deserializeErr |
| 222 | + Right tx -> pure tx |
| 223 | + |
| 224 | +fromChainPoint :: ChainPoint -> Text -> Blockfrost.BlockHash |
| 225 | +fromChainPoint chainPoint genesisBlockHash = case chainPoint of |
| 226 | + ChainPoint _ headerHash -> Blockfrost.BlockHash (decodeUtf8 . Base16.encode . serialiseToRawBytes $ headerHash) |
| 227 | + ChainPointAtGenesis -> Blockfrost.BlockHash genesisBlockHash |
0 commit comments