Define WithArrivalTime combinator

This commit defines a generic WithArrivalTime combinator to wrap a value
with its arrival time (as a Relative time). This is needed by Peras in
several places, e.g., to evaluate the voting rules.

Notably, we store a raw Relative time instead of a (arguably more apt)
SlotNo or PerasRoundNo to defer as much as possible having to deal with
the case where making this translation (timestamp -> slot/round) is not
possible due to the HFC time translation horizon. Instead, the client
will need to perform this translation in a context where such a failure
cannot occur or can be more easily dealt with.

Co-authored-by: Agustin Mista <agustin.mista@moduscreate.com>
Co-authored-by: Alexander Esgen <alexander.esgen@iohk.io>
Co-authored-by: Georgy Lukyanov <georgy.lukyanov@iohk.io>
Co-authored-by: Thomas BAGREL <thomas.bagrel@tweag.io>
Co-authored-by: Nicolas BACQUEY <nicolas.bacquey@tweag.io>

Author: 5 people

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

@@ -34,6 +34,7 @@ import Data.Word (Word64)
 import GHC.Generics (Generic)
 import NoThunks.Class
 import Ouroboros.Consensus.Block.Abstract
+import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..))
 import Ouroboros.Consensus.Peras.Params
 import Ouroboros.Consensus.Util
 import Ouroboros.Consensus.Util.Condense
@@ -143,6 +144,12 @@ instance HasPerasCertRound (PerasCert blk) where
 instance HasPerasCertRound (ValidatedPerasCert blk) where
   getPerasCertRound = getPerasCertRound . vpcCert
 
+instance
+  HasPerasCertRound cert =>
+  HasPerasCertRound (WithArrivalTime cert)
+  where
+  getPerasCertRound = getPerasCertRound . forgetArrivalTime
+
 -- | Extract the boosted block point from a Peras certificate container
 class HasPerasCertBoostedBlock cert blk | cert -> blk where
   getPerasCertBoostedBlock :: cert -> Point blk
@@ -153,9 +160,21 @@ instance HasPerasCertBoostedBlock (PerasCert blk) blk where
 instance HasPerasCertBoostedBlock (ValidatedPerasCert blk) blk where
   getPerasCertBoostedBlock = getPerasCertBoostedBlock . vpcCert
 
+instance
+  HasPerasCertBoostedBlock cert blk =>
+  HasPerasCertBoostedBlock (WithArrivalTime cert) blk
+  where
+  getPerasCertBoostedBlock = getPerasCertBoostedBlock . forgetArrivalTime
+
 -- | Extract the certificate boost from a Peras certificate container
 class HasPerasCertBoost cert where
   getPerasCertBoost :: cert -> PerasWeight
 
 instance HasPerasCertBoost (ValidatedPerasCert blk) where
   getPerasCertBoost = vpcCertBoost
+
+instance
+  HasPerasCertBoost cert =>
+  HasPerasCertBoost (WithArrivalTime cert)
+  where
+  getPerasCertBoost = getPerasCertBoost . forgetArrivalTime

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 
 module Ouroboros.Consensus.BlockchainTime.WallClock.Types
@@ -15,6 +17,10 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Types
     -- * Get current time (as 'RelativeTime')
   , SystemTime (..)
 
+    -- * Attach an arrival time (as 'RelativeTime') to an object
+  , WithArrivalTime (..)
+  , addArrivalTime
+
     -- * Slot length
   , getSlotLength
   , mkSlotLength
@@ -31,6 +37,7 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Types
 
 import Cardano.Slotting.Time
 import Data.Time.Clock (NominalDiffTime)
+import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
 
 addRelTime :: NominalDiffTime -> RelativeTime -> RelativeTime
@@ -60,3 +67,22 @@ data SystemTime m = SystemTime
   -- to reach 'SystemStart'. In tests this does nothing.
   }
   deriving NoThunks via OnlyCheckWhnfNamed "SystemTime" (SystemTime m)
+
+{-------------------------------------------------------------------------------
+  Attach an arrival time (as RelativeTime) to an object
+-------------------------------------------------------------------------------}
+
+-- | WithArrivalTime
+data WithArrivalTime a = WithArrivalTime
+  { getArrivalTime :: !RelativeTime
+  -- ^ The time at which the object arrived
+  , forgetArrivalTime :: !a
+  -- ^ The object without its arrival time
+  }
+  deriving (Show, Eq, Ord, Generic, NoThunks)
+
+-- | Add an arrival time to an object
+addArrivalTime :: Monad m => SystemTime m -> a -> m (WithArrivalTime a)
+addArrivalTime systemTime a = do
+  t <- systemTimeCurrent systemTime
+  return (WithArrivalTime t a)