consensus: implement TxLimits via the cardano-base:measures package

This has a few small benefits

  * define's TxMeasure `leq` via the pointwise minimum

  * removes the redundancy of specifying the `pointwiseMin` method per ledger
    instead of per 'Measure'

  * avoids the need for type applications, which let's us re-use the <=
    operator

and two large benefits

  * creates an opportunity for more use of deriving

  * the top-bounded meet-semilattice foundation means that `noOverrides` can be
    implemented as `top`; we don't need it to be a function from the (dynamic!)
    ledger limits anymore.

We had previously decided on a function because it made it trivial to override
only parts of the ledger-derived capacity. However, we simplified the override
representation (no more `NP`) and a interface that uses the static `top`
instead of the dynamic "current ledger capacity" is more appropriate for a
interface used for static configuration.

In other words, the function space was "too big" for the following reasons.

  * in practice, these values are parsed from a file, and I doubt the Node Team
    wants to parse functions anytime soon

  * we do not anticipate the node operator wanting to vary their override
    depending on the ledger capacity

The 'Measure' class's lattice semantics let us remove the function space
without losing any convenience.

cabal.project

@@ -164,7 +164,6 @@ constraints:
   -- constraint from dependent-sum-template (which is the library we actually use).
   , dependent-sum > 0.6.2.0
 
-
 -- ---------------------------------------------------------
 -- The "cabal" wrapper script provided by nix-shell will cut off / restore the remainder of this file
 -- in order to force usage of nix provided dependencies for `source-repository-package`s.
@@ -196,21 +195,24 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-base
-  tag: 0f409343c3655c4bacd7fab385d392ec5d5cca98
-  --sha256: 0js76inb7avg8c39c9k2zsr77sycg2vadylgvsswdsba808p6hr9
+  tag: 8c732560b201b5da8e3bdf175c6eda73a32d64bc
+  --sha256: 0nwy03wyd2ks4qxg47py7lm18karjz6vs7p8knmn3zy72i3n9rfi
   subdir:
+    base-deriving-via
     binary
     binary/test
     cardano-crypto-class
     cardano-crypto-praos
+    measures
+    orphans-deriving-via
     slotting
     strict-containers
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: 6b0fca7a73c317f3af7c14dd4dc38178cc78a6c8
-  --sha256: 0570g723ac8wf0zha37nsh4n0809rqqfx4j9i80hqkq18cysrglr
+  tag: 66ced00e5cf14b8caa9089a24d958fd309d2e6bb
+  --sha256: 1wbma14plky17bnwca264wb3ycl6lw9cv9zxykjn6pxiab9iqxh6
   subdir:
     alonzo/impl
     alonzo/test

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Forge.hs

@@ -146,14 +146,12 @@ forgeRegularBlock cfg maxTxCapacityOverrides bno sno st txs isLeader =
     epochSlots :: CC.Slot.EpochSlots
     epochSlots = byronEpochSlots cfg
 
-    maxTxCapacity = computeMaxTxCapacity st maxTxCapacityOverrides
-
     blockPayloads :: BlockPayloads
     blockPayloads =
         foldr
           extendBlockPayloads
           initBlockPayloads
-          (takeLargestPrefixThatFits maxTxCapacity txs)
+          (takeLargestPrefixThatFits maxTxCapacityOverrides st txs)
 
     txPayload :: CC.UTxO.TxPayload
     txPayload = CC.UTxO.mkTxPayload (bpTxs blockPayloads)

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Mempool.hs

@@ -85,10 +85,9 @@ import           Ouroboros.Consensus.Mempool.TxLimits
 -------------------------------------------------------------------------------}
 
 instance TxLimits ByronBlock where
-  type Measure ByronBlock = ByteSize
-  txMeasure    = ByteSize . txInBlockSize . txForgetValidated
-  maxCapacity  = ByteSize . txsMaxBytes
-  pointwiseMin = min
+  type TxMeasure ByronBlock = ByteSize
+  txMeasure        = ByteSize . txInBlockSize . txForgetValidated
+  txsBlockCapacity = ByteSize . txsMaxBytes
 
 {-------------------------------------------------------------------------------
   Transactions

ouroboros-consensus-shelley-test/test/Test/Consensus/Shelley/Coherence.hs

@@ -6,35 +6,25 @@ import           Data.Word (Word32)
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
 
-import           Cardano.Crypto.Hash (ShortHash)
-
 import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits
 
 import           Cardano.Ledger.Alonzo.Scripts (ExUnits, pointWiseExUnits)
 import           Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
 
-import           Ouroboros.Consensus.Shelley.Eras (AlonzoEra)
-import           Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock)
-import           Ouroboros.Consensus.Shelley.Ledger.Mempool (AlonzoMeasure (..))
-
-import           Test.Consensus.Shelley.MockCrypto (MockCrypto)
+import           Ouroboros.Consensus.Shelley.Ledger.Mempool (AlonzoExUnits (..),
+                     AlonzoMeasure (..))
 
 tests :: TestTree
 tests = testGroup "Shelley coherences" [
-      testProperty "TxLimits.lessEq uses pointWiseExUnits (<=)" lessEqCoherence
+      testProperty "TxLimits.<= uses pointWiseExUnits (<=)" leqCoherence
     ]
 
--- | 'TxLimits.lessEq' and @'pointWiseExUnits' (<=)@ must agree
-lessEqCoherence :: Word32 -> ExUnits -> ExUnits -> Property
-lessEqCoherence w eu1 eu2 =
+-- | 'TxLimits.<=' and @'pointWiseExUnits' (<=)@ must agree
+leqCoherence :: Word32 -> ExUnits -> ExUnits -> Property
+leqCoherence w eu1 eu2 =
     actual === expected
   where
-    inj eu = AlonzoMeasure (TxLimits.ByteSize w) eu
-
-    actual =
-      TxLimits.lessEq
-        @(ShelleyBlock (AlonzoEra (MockCrypto ShortHash)))
-        (inj eu1)
-        (inj eu2)
+    inj eu = AlonzoMeasure (TxLimits.ByteSize w) (AlonzoExUnits eu)
 
+    actual   = inj eu1 TxLimits.<= inj eu2
     expected = pointWiseExUnits (<=) eu1 eu2

ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal

@@ -48,6 +48,7 @@ library
                        Ouroboros.Consensus.Shelley.ShelleyHFC
 
   build-depends:       base              >=4.9   && <4.15
+                     , base-deriving-via
                      , bytestring        >=0.10  && <0.11
                      , cardano-binary
                      , cardano-crypto-class
@@ -58,8 +59,10 @@ library
                      , cborg             >=0.2.2 && <0.3
                      , containers        >=0.5   && <0.7
                      , data-default-class
+                     , measures
                      , mtl               >=2.2   && <2.3
                      , nothunks
+                     , orphans-deriving-via
                      , serialise         >=0.2   && <0.3
                      , strict-containers
                      , text              >=1.2   && <1.3

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs

@@ -69,9 +69,7 @@ forgeShelleyBlock hotKey canBeLeader cfg maxTxCapacityOverrides curNo curSlot ti
         SL.toTxSeq @era
       . Seq.fromList
       . fmap extractTxInBlock
-      $ takeLargestPrefixThatFits maxTxCapacity txs
-
-    maxTxCapacity = computeMaxTxCapacity tickedLedger maxTxCapacityOverrides
+      $ takeLargestPrefixThatFits maxTxCapacityOverrides tickedLedger txs
 
     extractTxInBlock :: (Validated (GenTx (ShelleyBlock era))) -> SL.TxInBlock era
     extractTxInBlock (ShelleyValidatedTx _ tx) = tx

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs

@@ -27,7 +27,8 @@ module Ouroboros.Consensus.Shelley.Ledger.Mempool (
   , mkShelleyTx
   , mkShelleyValidatedTx
   , perTxOverhead
-  -- * Exported for tests
+    -- * Exported for tests
+  , AlonzoExUnits (..)
   , AlonzoMeasure (..)
   ) where
 
@@ -41,6 +42,8 @@ import           NoThunks.Class (NoThunks (..))
 
 import           Cardano.Binary (Annotator (..), FromCBOR (..),
                      FullByteString (..), ToCBOR (..))
+import           Data.DerivingVia (InstantiatedAt (..))
+import           Data.Measure (BoundedMeasure, Measure)
 
 import           Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR)
 
@@ -272,52 +275,51 @@ theLedgerLens f x =
 -------------------------------------------------------------------------------}
 
 instance (SL.PraosCrypto c) => TxLimits (ShelleyBlock (ShelleyEra c)) where
-  type Measure (ShelleyBlock (ShelleyEra c)) = ByteSize
-  txMeasure    = ByteSize . txInBlockSize . txForgetValidated
-  maxCapacity  = ByteSize . txsMaxBytes
-  pointwiseMin = min
+  type TxMeasure (ShelleyBlock (ShelleyEra c)) = ByteSize
+  txMeasure        = ByteSize . txInBlockSize . txForgetValidated
+  txsBlockCapacity = ByteSize . txsMaxBytes
 
 instance (SL.PraosCrypto c) => TxLimits (ShelleyBlock (AllegraEra c)) where
-  type Measure (ShelleyBlock (AllegraEra c)) = ByteSize
-  txMeasure    = ByteSize . txInBlockSize . txForgetValidated
-  maxCapacity  = ByteSize . txsMaxBytes
-  pointwiseMin = min
+  type TxMeasure (ShelleyBlock (AllegraEra c)) = ByteSize
+  txMeasure        = ByteSize . txInBlockSize . txForgetValidated
+  txsBlockCapacity = ByteSize . txsMaxBytes
 
 instance (SL.PraosCrypto c) => TxLimits (ShelleyBlock (MaryEra c)) where
-  type Measure (ShelleyBlock (MaryEra c)) = ByteSize
-  txMeasure    = ByteSize . txInBlockSize . txForgetValidated
-  maxCapacity  = ByteSize . txsMaxBytes
-  pointwiseMin = min
-
-data AlonzoMeasure = AlonzoMeasure {
-    byteSize :: !ByteSize
-  , exUnits  :: !ExUnits
-  } deriving stock (Show, Eq)
-
-instance Semigroup AlonzoMeasure where
-  (AlonzoMeasure bs1 exu1) <> (AlonzoMeasure bs2 exu2) =
-    AlonzoMeasure (bs1 <> bs2) (exu1 <> exu2)
-
-instance Monoid AlonzoMeasure where
-  mempty = AlonzoMeasure mempty mempty
+  type TxMeasure (ShelleyBlock (MaryEra c)) = ByteSize
+  txMeasure        = ByteSize . txInBlockSize . txForgetValidated
+  txsBlockCapacity = ByteSize . txsMaxBytes
 
 instance ( SL.PraosCrypto c
          ) => TxLimits (ShelleyBlock (AlonzoEra c)) where
 
-  type Measure (ShelleyBlock (AlonzoEra c)) = AlonzoMeasure
+  type TxMeasure (ShelleyBlock (AlonzoEra c)) = AlonzoMeasure
 
   txMeasure validatedGenTx@(ShelleyValidatedTx _ tx) =
     AlonzoMeasure {
         byteSize = ByteSize . txInBlockSize $ txForgetValidated validatedGenTx
-      , exUnits  = totExUnits tx
+      , exUnits  = AlonzoExUnits $ totExUnits tx
       }
 
-  maxCapacity ledgerState =
-    let pparams  = getPParams $ tickedShelleyLedgerState ledgerState
-    in AlonzoMeasure {
-        byteSize = ByteSize $ txsMaxBytes ledgerState
-      , exUnits  = getField @"_maxBlockExUnits" pparams
-      }
+  txsBlockCapacity ledgerState =
+      AlonzoMeasure {
+          byteSize = ByteSize $ txsMaxBytes ledgerState
+        , exUnits  = AlonzoExUnits $ getField @"_maxBlockExUnits" pparams
+        }
+    where
+      pparams = getPParams $ tickedShelleyLedgerState ledgerState
 
-  pointwiseMin (AlonzoMeasure bs1 (ExUnits mem1 steps1)) (AlonzoMeasure bs2 (ExUnits mem2 steps2)) =
-    AlonzoMeasure (bs1 `min` bs2) (ExUnits (mem1 `min` mem2) (steps1 `min` steps2))
+data AlonzoMeasure = AlonzoMeasure {
+    byteSize :: !ByteSize
+  , exUnits  :: !AlonzoExUnits
+  } deriving stock (Eq, Generic, Show)
+    deriving (BoundedMeasure, Measure)
+         via (InstantiatedAt Generic AlonzoMeasure)
+
+-- | Used only to avoid orphan instances
+--
+-- TODO won't be necessary once cardano-ledger-specs declares BoundedMeasure
+-- ExUnits
+newtype AlonzoExUnits = AlonzoExUnits ExUnits
+  deriving newtype (Eq, Show)
+  deriving (BoundedMeasure, Measure)
+       via (InstantiatedAt Generic ExUnits)

ouroboros-consensus/ouroboros-consensus.cabal

@@ -280,6 +280,7 @@ library
                        ViewPatterns
 
   build-depends:       base              >=4.9 && <4.15
+                     , base-deriving-via
                      , base16-bytestring
                      , bimap             >=0.3   && <0.5
                      , binary            >=0.8   && <0.11
@@ -297,6 +298,7 @@ library
                      , filelock
                      , filepath          >=1.4   && <1.5
                      , hashable
+                     , measures
                      , mtl               >=2.2   && <2.3
                      , nothunks          >=0.1.2 && <0.2
                      , psqueues          >=0.2.3 && <0.3

ouroboros-consensus/src/Ouroboros/Consensus/Block/Forging.hs

@@ -21,7 +21,6 @@ module Ouroboros.Consensus.Block.Forging (
     -- * 'UpdateInfo'
   , UpdateInfo (..)
     -- * Selecting transaction sequence prefixes
-  , computeMaxTxCapacity
   , takeLargestPrefixThatFits
   ) where
 
@@ -30,6 +29,7 @@ import           Data.Kind (Type)
 import           Data.Text (Text)
 import           GHC.Stack
 
+import qualified Data.Measure as Measure
 
 import           Ouroboros.Consensus.Block.Abstract
 import           Ouroboros.Consensus.Config
@@ -152,36 +152,27 @@ data BlockForging m blk = BlockForging {
         -> m blk
     }
 
--- | Computes maximum tx capacity
+-- | The prefix of transactions to include in the block
 --
--- It queries the ledger state for the current limit and then applies the given
--- override. The result is the pointwise minimum of the ledger-specific capacity
--- and the result of the override. In other words, the override can only reduce
--- (parts of) the 'TxLimits.Measure'.
-computeMaxTxCapacity ::
-     TxLimits blk
-  => TickedLedgerState blk
-  -> TxLimits.Overrides blk
-  -> TxLimits.Measure blk
-computeMaxTxCapacity ledger overrides =
-    TxLimits.applyOverrides overrides (TxLimits.maxCapacity ledger)
-
--- | Filters out all transactions that do not fit the maximum size that is
--- passed to this function as the first argument. Value of that first argument
--- will most often by calculated by calling 'computeMaxTxCapacity'
+-- Filters out all transactions that do not fit the maximum size of total
+-- transactions in a single block, which is determined by querying the ledger
+-- state for the current limit and the given override. The result is the
+-- pointwise minimum of the ledger-specific capacity and the result of the
+-- override. In other words, the override can only reduce (parts of) the
+-- 'TxLimits.TxMeasure'.
 takeLargestPrefixThatFits ::
-     forall blk. TxLimits blk
-  => TxLimits.Measure blk
+     TxLimits blk
+  => TxLimits.Overrides blk
+  -> TickedLedgerState blk
   -> [Validated (GenTx blk)]
   -> [Validated (GenTx blk)]
-takeLargestPrefixThatFits maxTxCapacity = go mempty
+takeLargestPrefixThatFits overrides ledger txs =
+    Measure.take TxLimits.txMeasure capacity txs
   where
-    go acc = \case
-      (tx : remainingTxs) | fits -> tx : go acc' remainingTxs
-        where
-          acc' = acc <> TxLimits.txMeasure tx
-          fits = TxLimits.lessEq @blk acc' maxTxCapacity
-      _ -> []
+    capacity =
+      TxLimits.applyOverrides
+        overrides
+        (TxLimits.txsBlockCapacity ledger)
 
 data ShouldForge blk =
     -- | Before check whether we are a leader in this slot, we tried to update