|
| 1 | +{-# LANGUAGE DataKinds #-} |
| 2 | +{-# LANGUAGE DeriveGeneric #-} |
| 3 | +{-# LANGUAGE DerivingVia #-} |
| 4 | +{-# LANGUAGE FlexibleContexts #-} |
| 5 | +{-# LANGUAGE FlexibleInstances #-} |
| 6 | +{-# LANGUAGE OverloadedStrings #-} |
| 7 | +{-# LANGUAGE PatternSynonyms #-} |
| 8 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 9 | +{-# LANGUAGE StandaloneDeriving #-} |
| 10 | +{-# LANGUAGE TypeApplications #-} |
| 11 | +{-# LANGUAGE TypeFamilies #-} |
| 12 | +{-# LANGUAGE TypeOperators #-} |
| 13 | +{-# LANGUAGE UndecidableInstances #-} |
| 14 | +{-# LANGUAGE ViewPatterns #-} |
| 15 | +{-# OPTIONS_GHC -Wno-orphans #-} |
| 16 | +{-# OPTIONS_HADDOCK not-home #-} |
| 17 | + |
| 18 | +-- | Provides BlockBody internals |
| 19 | +-- |
| 20 | +-- = Warning |
| 21 | +-- |
| 22 | +-- This module is considered __internal__. |
| 23 | +-- |
| 24 | +-- The contents of this module may change __in any way whatsoever__ |
| 25 | +-- and __without any warning__ between minor versions of this package. |
| 26 | +module Cardano.Ledger.Dijkstra.BlockBody.Internal ( |
| 27 | + DijkstraBlockBody (DijkstraBlockBody, ..), |
| 28 | + hashDijkstraSegWits, |
| 29 | + alignedValidFlags, |
| 30 | + mkBasicBlockBodyDijkstra, |
| 31 | + txSeqBlockBodyDijkstraL, |
| 32 | +) where |
| 33 | + |
| 34 | +import qualified Cardano.Crypto.Hash as Hash |
| 35 | +import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), IsValid (..)) |
| 36 | +import Cardano.Ledger.Binary ( |
| 37 | + Annotator (..), |
| 38 | + DecCBOR (..), |
| 39 | + EncCBORGroup (..), |
| 40 | + encCBOR, |
| 41 | + encodeFoldableEncoder, |
| 42 | + encodeFoldableMapEncoder, |
| 43 | + encodePreEncoded, |
| 44 | + serialize, |
| 45 | + withSlice, |
| 46 | + ) |
| 47 | +import Cardano.Ledger.Core |
| 48 | +import Cardano.Ledger.Dijkstra.Era |
| 49 | +import Cardano.Ledger.Dijkstra.Tx () |
| 50 | +import Cardano.Ledger.Shelley.BlockBody (auxDataSeqDecoder) |
| 51 | +import Control.Monad (unless) |
| 52 | +import Data.ByteString (ByteString) |
| 53 | +import Data.ByteString.Builder (Builder, shortByteString, toLazyByteString) |
| 54 | +import qualified Data.ByteString.Lazy as BSL |
| 55 | +import Data.Coerce (coerce) |
| 56 | +import Data.Maybe.Strict (maybeToStrictMaybe, strictMaybeToMaybe) |
| 57 | +import qualified Data.Sequence as Seq |
| 58 | +import Data.Sequence.Strict (StrictSeq) |
| 59 | +import qualified Data.Sequence.Strict as StrictSeq |
| 60 | +import Data.Typeable (Typeable) |
| 61 | +import GHC.Generics (Generic) |
| 62 | +import Lens.Micro |
| 63 | +import Lens.Micro.Extras (view) |
| 64 | +import NoThunks.Class (AllowThunksIn (..), NoThunks) |
| 65 | + |
| 66 | +-- ================================================= |
| 67 | + |
| 68 | +-- $BlockBody |
| 69 | +-- |
| 70 | +-- * BlockBody |
| 71 | +-- |
| 72 | +-- BlockBody provides an alternate way of formatting transactions in a block, in |
| 73 | +-- order to support segregated witnessing. |
| 74 | + |
| 75 | +data DijkstraBlockBody era = DijkstraBlockBodyInternal |
| 76 | + { dbbTxs :: !(StrictSeq (Tx TopTx era)) |
| 77 | + , dbbHash :: Hash.Hash HASH EraIndependentBlockBody |
| 78 | + -- ^ Memoized hash to avoid recomputation. Lazy on purpose. |
| 79 | + , dbbTxsBodyBytes :: BSL.ByteString |
| 80 | + -- ^ Bytes encoding @Seq ('TxBody' era)@ |
| 81 | + , dbbTxsWitsBytes :: BSL.ByteString |
| 82 | + -- ^ Bytes encoding @Seq ('TxWits' era)@ |
| 83 | + , dbbTxsAuxDataBytes :: BSL.ByteString |
| 84 | + -- ^ Bytes encoding a @'TxAuxData')@. Missing indices have |
| 85 | + -- 'SNothing' for metadata |
| 86 | + , dbbTxsIsValidBytes :: BSL.ByteString |
| 87 | + -- ^ Bytes representing a set of integers. These are the indices of |
| 88 | + -- transactions with 'isValid' == False. |
| 89 | + } |
| 90 | + deriving (Generic) |
| 91 | + |
| 92 | +instance EraBlockBody DijkstraEra where |
| 93 | + type BlockBody DijkstraEra = DijkstraBlockBody DijkstraEra |
| 94 | + mkBasicBlockBody = mkBasicBlockBodyDijkstra |
| 95 | + txSeqBlockBodyL = txSeqBlockBodyDijkstraL |
| 96 | + hashBlockBody = dbbHash |
| 97 | + numSegComponents = 4 |
| 98 | + |
| 99 | +mkBasicBlockBodyDijkstra :: |
| 100 | + ( SafeToHash (TxWits era) |
| 101 | + , BlockBody era ~ DijkstraBlockBody era |
| 102 | + , AlonzoEraTx era |
| 103 | + ) => |
| 104 | + BlockBody era |
| 105 | +mkBasicBlockBodyDijkstra = DijkstraBlockBody mempty |
| 106 | +{-# INLINEABLE mkBasicBlockBodyDijkstra #-} |
| 107 | + |
| 108 | +txSeqBlockBodyDijkstraL :: |
| 109 | + ( SafeToHash (TxWits era) |
| 110 | + , BlockBody era ~ DijkstraBlockBody era |
| 111 | + , AlonzoEraTx era |
| 112 | + ) => |
| 113 | + Lens' (BlockBody era) (StrictSeq (Tx TopTx era)) |
| 114 | +txSeqBlockBodyDijkstraL = lens dbbTxs (\_ s -> DijkstraBlockBody s) |
| 115 | +{-# INLINEABLE txSeqBlockBodyDijkstraL #-} |
| 116 | + |
| 117 | +pattern DijkstraBlockBody :: |
| 118 | + forall era. |
| 119 | + ( AlonzoEraTx era |
| 120 | + , SafeToHash (TxWits era) |
| 121 | + ) => |
| 122 | + StrictSeq (Tx TopTx era) -> |
| 123 | + DijkstraBlockBody era |
| 124 | +pattern DijkstraBlockBody xs <- |
| 125 | + DijkstraBlockBodyInternal xs _ _ _ _ _ |
| 126 | + where |
| 127 | + DijkstraBlockBody txns = |
| 128 | + let version = eraProtVerLow @era |
| 129 | + serializeFoldablePreEncoded x = |
| 130 | + serialize version $ |
| 131 | + encodeFoldableEncoder encodePreEncoded x |
| 132 | + metaChunk index m = encodeIndexed <$> strictMaybeToMaybe m |
| 133 | + where |
| 134 | + encodeIndexed metadata = encCBOR index <> encodePreEncoded metadata |
| 135 | + txSeqBodies = |
| 136 | + serializeFoldablePreEncoded $ originalBytes . view bodyTxL <$> txns |
| 137 | + txSeqWits = |
| 138 | + serializeFoldablePreEncoded $ originalBytes . view witsTxL <$> txns |
| 139 | + txSeqAuxDatas = |
| 140 | + serialize version . encodeFoldableMapEncoder metaChunk $ |
| 141 | + fmap originalBytes . view auxDataTxL <$> txns |
| 142 | + txSeqIsValids = |
| 143 | + serialize version $ encCBOR $ nonValidatingIndices txns |
| 144 | + in DijkstraBlockBodyInternal |
| 145 | + { dbbTxs = txns |
| 146 | + , dbbHash = hashDijkstraSegWits txSeqBodies txSeqWits txSeqAuxDatas txSeqIsValids |
| 147 | + , dbbTxsBodyBytes = txSeqBodies |
| 148 | + , dbbTxsWitsBytes = txSeqWits |
| 149 | + , dbbTxsAuxDataBytes = txSeqAuxDatas |
| 150 | + , dbbTxsIsValidBytes = txSeqIsValids |
| 151 | + } |
| 152 | + |
| 153 | +{-# COMPLETE DijkstraBlockBody #-} |
| 154 | + |
| 155 | +deriving via |
| 156 | + AllowThunksIn |
| 157 | + '[ "dbbHash" |
| 158 | + , "dbbTxsBodyBytes" |
| 159 | + , "dbbTxsWitsBytes" |
| 160 | + , "dbbTxsAuxDataBytes" |
| 161 | + , "dbbTxsIsValidBytes" |
| 162 | + ] |
| 163 | + (DijkstraBlockBody era) |
| 164 | + instance |
| 165 | + (Typeable era, NoThunks (Tx TopTx era)) => NoThunks (DijkstraBlockBody era) |
| 166 | + |
| 167 | +deriving stock instance Show (Tx TopTx era) => Show (DijkstraBlockBody era) |
| 168 | + |
| 169 | +deriving stock instance Eq (Tx TopTx era) => Eq (DijkstraBlockBody era) |
| 170 | + |
| 171 | +-------------------------------------------------------------------------------- |
| 172 | +-- Serialisation and hashing |
| 173 | +-------------------------------------------------------------------------------- |
| 174 | + |
| 175 | +instance Era era => EncCBORGroup (DijkstraBlockBody era) where |
| 176 | + encCBORGroup (DijkstraBlockBodyInternal _ _ bodyBytes witsBytes metadataBytes invalidBytes) = |
| 177 | + encodePreEncoded $ |
| 178 | + BSL.toStrict $ |
| 179 | + bodyBytes <> witsBytes <> metadataBytes <> invalidBytes |
| 180 | + listLen _ = 4 |
| 181 | + listLenBound _ = 4 |
| 182 | + |
| 183 | +hashDijkstraSegWits :: |
| 184 | + BSL.ByteString -> |
| 185 | + -- | Bytes for transaction bodies |
| 186 | + BSL.ByteString -> |
| 187 | + -- | Bytes for transaction witnesses |
| 188 | + BSL.ByteString -> |
| 189 | + -- | Bytes for transaction auxiliary datas |
| 190 | + BSL.ByteString -> |
| 191 | + -- | Bytes for transaction isValid flags |
| 192 | + Hash HASH EraIndependentBlockBody |
| 193 | +hashDijkstraSegWits txSeqBodies txSeqWits txAuxData txSeqIsValids = |
| 194 | + coerce . hashLazy . toLazyByteString $ |
| 195 | + hashPart txSeqBodies |
| 196 | + <> hashPart txSeqWits |
| 197 | + <> hashPart txAuxData |
| 198 | + <> hashPart txSeqIsValids |
| 199 | + where |
| 200 | + hashLazy :: BSL.ByteString -> Hash HASH ByteString |
| 201 | + hashLazy = Hash.hashWith id . BSL.toStrict |
| 202 | + {-# INLINE hashLazy #-} |
| 203 | + hashPart :: BSL.ByteString -> Builder |
| 204 | + hashPart = shortByteString . Hash.hashToBytesShort . hashLazy |
| 205 | + {-# INLINE hashPart #-} |
| 206 | +{-# INLINE hashDijkstraSegWits #-} |
| 207 | + |
| 208 | +instance |
| 209 | + ( AlonzoEraTx era |
| 210 | + , DecCBOR (Annotator (TxAuxData era)) |
| 211 | + , DecCBOR (Annotator (TxBody TopTx era)) |
| 212 | + , DecCBOR (Annotator (TxWits era)) |
| 213 | + ) => |
| 214 | + DecCBOR (Annotator (DijkstraBlockBody era)) |
| 215 | + where |
| 216 | + decCBOR = do |
| 217 | + (bodies, bodiesAnn) <- withSlice decCBOR |
| 218 | + (wits, witsAnn) <- withSlice decCBOR |
| 219 | + let bodiesLength = length bodies |
| 220 | + inRange x = (0 <= x) && (x <= (bodiesLength - 1)) |
| 221 | + witsLength = length wits |
| 222 | + (auxData, auxDataAnn) <- withSlice $ do |
| 223 | + auxDataMap <- decCBOR |
| 224 | + auxDataSeqDecoder bodiesLength auxDataMap |
| 225 | + |
| 226 | + (isValIdxs, isValAnn) <- withSlice decCBOR |
| 227 | + let validFlags = alignedValidFlags bodiesLength isValIdxs |
| 228 | + unless (bodiesLength == witsLength) $ |
| 229 | + fail $ |
| 230 | + "different number of transaction bodies (" |
| 231 | + <> show bodiesLength |
| 232 | + <> ") and witness sets (" |
| 233 | + <> show witsLength |
| 234 | + <> ")" |
| 235 | + unless (all inRange isValIdxs) $ |
| 236 | + fail $ |
| 237 | + "Some IsValid index is not in the range: 0 .. " |
| 238 | + <> show (bodiesLength - 1) |
| 239 | + <> ", " |
| 240 | + <> show isValIdxs |
| 241 | + |
| 242 | + let txns = |
| 243 | + sequenceA $ |
| 244 | + StrictSeq.forceToStrict $ |
| 245 | + Seq.zipWith4 dijkstraSegwitTx bodies wits validFlags auxData |
| 246 | + pure $ |
| 247 | + DijkstraBlockBodyInternal |
| 248 | + <$> txns |
| 249 | + <*> (hashDijkstraSegWits <$> bodiesAnn <*> witsAnn <*> auxDataAnn <*> isValAnn) |
| 250 | + <*> bodiesAnn |
| 251 | + <*> witsAnn |
| 252 | + <*> auxDataAnn |
| 253 | + <*> isValAnn |
| 254 | + |
| 255 | +-------------------------------------------------------------------------------- |
| 256 | +-- Internal utility functions |
| 257 | +-------------------------------------------------------------------------------- |
| 258 | + |
| 259 | +-- | Given a sequence of transactions, return the indices of those which do not |
| 260 | +-- validate. We store the indices of the non-validating transactions because we |
| 261 | +-- expect this to be a much smaller set than the validating transactions. |
| 262 | +nonValidatingIndices :: AlonzoEraTx era => StrictSeq (Tx TopTx era) -> [Int] |
| 263 | +nonValidatingIndices (StrictSeq.fromStrict -> xs) = |
| 264 | + Seq.foldrWithIndex |
| 265 | + ( \idx tx acc -> |
| 266 | + if tx ^. isValidTxL == IsValid False |
| 267 | + then idx : acc |
| 268 | + else acc |
| 269 | + ) |
| 270 | + [] |
| 271 | + xs |
| 272 | + |
| 273 | +-- | Given the number of transactions, and the set of indices for which these |
| 274 | +-- transactions do not validate, create an aligned sequence of `IsValid` |
| 275 | +-- flags. |
| 276 | +-- |
| 277 | +-- This function operates much as the inverse of 'nonValidatingIndices'. |
| 278 | +alignedValidFlags :: Int -> [Int] -> Seq.Seq IsValid |
| 279 | +alignedValidFlags = alignedValidFlags' (-1) |
| 280 | + where |
| 281 | + alignedValidFlags' _ n [] = Seq.replicate n $ IsValid True |
| 282 | + alignedValidFlags' prev n (x : xs) = |
| 283 | + Seq.replicate (x - prev - 1) (IsValid True) |
| 284 | + Seq.>< IsValid False |
| 285 | + Seq.<| alignedValidFlags' x (n - (x - prev)) xs |
| 286 | + |
| 287 | +-- | Construct an annotated Alonzo style transaction. |
| 288 | +dijkstraSegwitTx :: |
| 289 | + AlonzoEraTx era => |
| 290 | + Annotator (TxBody TopTx era) -> |
| 291 | + Annotator (TxWits era) -> |
| 292 | + IsValid -> |
| 293 | + Maybe (Annotator (TxAuxData era)) -> |
| 294 | + Annotator (Tx TopTx era) |
| 295 | +dijkstraSegwitTx txBodyAnn txWitsAnn txIsValid txAuxDataAnn = Annotator $ \bytes -> do |
| 296 | + txBody <- runAnnotator txBodyAnn bytes |
| 297 | + txWits <- runAnnotator txWitsAnn bytes |
| 298 | + txAuxData <- mapM (`runAnnotator` bytes) txAuxDataAnn |
| 299 | + pure $ |
| 300 | + mkBasicTx txBody |
| 301 | + & witsTxL |
| 302 | + .~ txWits |
| 303 | + & auxDataTxL |
| 304 | + .~ maybeToStrictMaybe txAuxData |
| 305 | + & isValidTxL |
| 306 | + .~ txIsValid |
0 commit comments