Add support for UTxO HD

[dnadales]

With the introduction of UTxO HD the LedgerState type family gained an extra parameter:

    data family LedgerState blk :: LedgerStateKind
    
    type MapKind         = {- key -} Type -> {- value -} Type -> Type
    type LedgerStateKind = MapKind -> Type

The extra parameter is intended to represent the "map kind", which refers to the different type of "tables" that can be found in an instance of consensus' LedgerState, eg:

    data ApplyMapKind' :: MapKind' -> Type -> Type -> Type where
      ApplyDiffMK     :: !(UtxoDiff    k v)                    -> ApplyMapKind' DiffMK'       k v
      ApplyEmptyMK    ::                                          ApplyMapKind' EmptyMK'      k v
      ApplyKeysMK     :: !(UtxoKeys    k v)                    -> ApplyMapKind' KeysMK'       k v
      ApplySeqDiffMK  :: !(SeqUtxoDiff k v)                    -> ApplyMapKind' SeqDiffMK'    k v
      ApplyTrackingMK :: !(UtxoValues  k v) -> !(UtxoDiff k v) -> ApplyMapKind' TrackingMK'   k v
      ApplyValuesMK   :: !(UtxoValues  k v)                    -> ApplyMapKind' ValuesMK'     k v

At the moment the ledger can remain blissfully ignorant of this additional parameter, and the fact that consensus manipulates tables when applying a block because the ledger tables live outside the actual ledger state (as defined in the ledger code):

    data instance LedgerState (ShelleyBlock proto era) mk = ShelleyLedgerState {
          shelleyLedgerTip        :: !(WithOrigin (ShelleyTip proto era))
        , shelleyLedgerState      :: !(SL.NewEpochState era)
        , shelleyLedgerTransition :: !ShelleyTransition
        , shelleyLedgerTables     :: !(LedgerTables (LedgerState (ShelleyBlock proto era)) mk)
        }

Note the new shelleyLedgerTables field.

With the addition of UTxO HD, the block application type changed so that it takes a consensus' LedgerState containing values, and return a ledger state with the differences that resulted from applying the block.

    applyBlockLedgerResult ::
         HasCallStack
      => LedgerCfg l
      -> blk
      -> Ticked1 l ValuesMK
      -> Except (LedgerErr l) (LedgerResult l (l DiffMK))

Since the actual ledger state is not aware of tables, values, or differences, the instance for applyBlockLedgerResult has to perform certain manipulations on the consensus LedgerState and accompanying tables. Such manipulations are implemented in the applyHelper function, which we show at the end for completeness' sake, but it a nutshell this is what happens:

    -- The actual ledger state does not contain any utxo yet.
    (st {}             , utxo_values) 
    - stowLedgerTables ->
    -- The utxo is transferred from the ledger tables portion of the state to the
    -- actual ledger state.
    (st {utxo_values}  , ())
    - applyBlock ->
    -- The block is applied, which modifies the actual ledger state, including the
    -- utxo set inside it.
    (st' {utxo_values'}, ())        
    - unstowLedgerTables ->
    -- The utxo is trasferred to the ledger tables portion of the consensus' ledger
    -- state.
    (st' {}            , utxo_values') 
    - track (st {}           , utxo_values) ->
    -- Using consensus' ledger state before applying the block we can calculate the
    -- differences, which together with the utxo_values' result in a tracking map
    -- (See ''ApplyTrackingMK' above).
    (st' {}            , (utxo_values', utxo_diff))
    - forgetLedgerTablesValues ->
    -- By forgetting the values, we obtain the ledger state with the diffs, which is
    -- the output type that 'applyBlockLedgerResult' expects.
    (st' {}            , utxo_diff)

The goal of this issue is to parametrize the ledger state over map kinds, and change the ledger rules so that a tracking map (ie new values + diffs) is produced instead of just new values. To this end, it might be useful to look at the functions that are already implemented in consensus, eg calculateDifference. After this change is implemented consensus should not need to stow and unstow tables, and calculate differences.

Supporting information

    data ApplyMapKind' :: MapKind' -> Type -> Type -> Type where
    
      ApplyTrackingMK :: !(UtxoValues  k v) -> !(UtxoDiff k v) -> ApplyMapKind' TrackingMK' k v
    
    applyBlock :: forall m c l blk
                . (ApplyBlock l blk, TickedTableStuff l, Monad m, c, HasCallStack)
               => LedgerCfg l
               -> Ap m l blk c
               -> LedgerDB l
               -> m (l DiffMK)
    applyBlock cfg ap db = case ap of
      -- ...
      ApplyVal b -> withBlockReadSets b $ \lh ->
          either (throwLedgerError db (blockRealPoint b)) return
          $ runExcept
          $ tickThenApply cfg b lh
    
      where
        withBlockReadSets
          :: ReadsKeySets m l
          => blk
          -> (l ValuesMK -> m (l DiffMK))
          -> m (l DiffMK)
    
    tickThenApply ::
         (ApplyBlock l blk, TickedTableStuff l)
      => LedgerCfg l
      -> blk
      -> l ValuesMK
      -> Except (LedgerErr l) (l DiffMK)
    tickThenApply = fmap lrResult ..: tickThenApplyLedgerResult
    
    tickThenApplyLedgerResult ::
         (ApplyBlock l blk, TickedTableStuff l)
      => LedgerCfg l
      -> blk
      -> l ValuesMK
      -> Except (LedgerErr l) (LedgerResult l (l DiffMK))
    tickThenApplyLedgerResult cfg blk l = do
      let lrTick = applyChainTickLedgerResult cfg (blockSlot blk) (forgetLedgerTables l)
      lrBlock <-    applyBlockLedgerResult     cfg            blk  (applyLedgerTablesDiffsTicked l (lrResult lrTick))
      pure LedgerResult {
          lrEvents = lrEvents lrTick <> lrEvents lrBlock
        , lrResult = prependLedgerTablesDiffsFromTicked (lrResult lrTick) (lrResult lrBlock)
        }
    
    
    -- NOTE For Shelley we have:
    instance ShelleyCompatible proto era
          => ApplyBlock (LedgerState (ShelleyBlock proto era)) (ShelleyBlock proto era) where
      applyBlockLedgerResult =
          applyHelper (swizzle ..: appBlk)
    
    applyLedgerTablesDiffsTicked
      :: TickedTableStuff l =>         l ValuesMK -> Ticked1 l DiffMK -> Ticked1 l ValuesMK
    prependLedgerTablesDiffsFromTicked
      :: TickedTableStuff l => Ticked1 l DiffMK   ->         l DiffMK ->         l DiffMK

    applyHelper :: forall proto m era.
         (ShelleyCompatible proto era, Monad m)
      => (   SL.Globals
          -> SL.NewEpochState era
          -> SL.Block (SL.BHeaderView (EraCrypto era)) era
          -> m (LedgerResult
                  (LedgerState (ShelleyBlock proto era))
                  (SL.NewEpochState era)
               )
         )
      -> LedgerConfig (ShelleyBlock proto era)
      -> ShelleyBlock proto era
      -> TickedLedgerState (ShelleyBlock proto era) ValuesMK
      -> m (LedgerResult
              (LedgerState (ShelleyBlock proto era))
              (LedgerState (ShelleyBlock proto era) DiffMK))
    applyHelper f cfg blk stBefore = do
        let TickedShelleyLedgerState{
                tickedShelleyLedgerTransition
              , tickedShelleyLedgerState
              } = cnv $ stowLedgerTables $ vnc stBefore
    
        ledgerResult <-
          f
            globals
            tickedShelleyLedgerState
            ( let b  = shelleyBlockRaw blk
                  h' = mkHeaderView (SL.bheader b)
              -- Jared Corduan explains that the " Unsafe " here ultimately only
              -- means the value must not be serialized. We're only passing it to
              -- 'STS.applyBlockOpts', which does not serialize it. So this is a
              -- safe use.
              in SL.UnsafeUnserialisedBlock h' (SL.bbody b)
            )
    
        let track ::
                 LedgerState (ShelleyBlock proto era) ValuesMK
              -> LedgerState (ShelleyBlock proto era) TrackingMK
            track = calculateDifference stBefore
    
    
        return $ ledgerResult <&> \newNewEpochState -> forgetLedgerTablesValues $ track $ unstowLedgerTables $ ShelleyLedgerState {
            shelleyLedgerTip = NotOrigin ShelleyTip {
                shelleyTipBlockNo = blockNo   blk
              , shelleyTipSlotNo  = blockSlot blk
              , shelleyTipHash    = blockHash blk
              }
          , shelleyLedgerState =
              newNewEpochState
          , shelleyLedgerTransition = ShelleyTransitionInfo {
                shelleyAfterVoting =
                  -- We count the number of blocks that have been applied after the
                  -- voting deadline has passed.
                  (if blockSlot blk >= votingDeadline then succ else id) $
                    shelleyAfterVoting tickedShelleyLedgerTransition
              }
          , shelleyLedgerTables = emptyLedgerTables
          }
      where
        globals = shelleyLedgerGlobals cfg
        swindow = SL.stabilityWindow globals
    
        ei :: EpochInfo Identity
        ei = SL.epochInfoPure globals
    
        -- The start of the next epoch is within the safe zone, always.
        startOfNextEpoch :: SlotNo
        startOfNextEpoch = runIdentity $ do
            blockEpoch <- epochInfoEpoch ei (blockSlot blk)
            let nextEpoch = succ blockEpoch
            epochInfoFirst ei nextEpoch
    
        -- The block must come in strictly before the voting deadline
        -- See Fig 13, "Protocol Parameter Update Inference Rules", of the
        -- Shelley specification.
        votingDeadline :: SlotNo
        votingDeadline = subSlots (2 * swindow) startOfNextEpoch

[Soupstraw]

I'm assuming that's the related PR on ouroboros-network: input-output-hk/ouroboros-network#3863

[dnadales]

Yes, indeed. Note that this is still in the prototyping phase :scientist:

[Soupstraw]

Alright, I'll leave it be for now, but I'll be happy to work on this once the linked PR is ready.

[JaredCorduan]

Alright, I'll leave it be for now, but I'll be happy to work on this once the linked PR is ready.

That's fine. but I do think a lot of the work on the ledger side could be done in parallel (at the risk of things not going as planned when we go to integration).

[dnadales]

Right, the fact that this is still a prototype does not mean the ledger team cannot work on it as soon as it has the capacity :)

[dnadales]

@JaredCorduan we are not blocked by this, and we don't expect to be anytime soon. However, after @TimSheard has gone through the exploration phase, maybe it'd be a good idea to have a prototype interface that we could try to integrate with the consensus code. CC: @Jasagredo

[TimSheard]

After our meeting today, it became clear that the current implementation needs nothing from the ledger side. Consensus sends the ledger a filtered UTxO, the Ledger updates it and then send that version back to Consensus. There they take the before and after UTxO and compute the Diff. At some future time it might speed things up if the Ledger sent back a Diff rather than the updated UTxO. This seems like a reasonable thing to do. What woud be required.

1. UTxO would become a virtual pair (old,diff)
2. Updates to theUTxO would alter the 'diff' part.
3. Observations of the UTxO would have to be rewritten to use the virtual pair

There are quite a few observations of the UtxO, especially in the tests, so this would NOT be a trival chore. How much it woud speed things up, remains to be seen.

[dnadales]

Thank you for adding your observations Tim.